top of page
立体構造

Program Samples(サンプルプログラム)

 
 
[JavaScript]   ドラッグしてドット絵を描こう

<!--2019/5/5 K.Narita-->
<!DOCTYPE html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<script type="text/javascript">
  function mousemove(e){
    var str = "X座標:" + e.pageX + " Y座標:" + e.pageY;
    document.getElementById("xy").innerText = str;
  }
  var flg = false;
  window.document.onmousemove=move;
  window.document.onmouseup=up;
  function down($event){
    flg =true;
  }
function up(){
   flg = false;
}
function move($event){
  var str = "X座標:" + ($event.clientX) + " Y座標:" + ($event.clientY);
  document.getElementById("xy").innerText = str;
  var x, y, n=50, obj;
  x=(($event.clientX));
  y=(($event.clientY));
  x=Math.floor(x/30);
  y=Math.floor(y/30);
  if(0<=x && x<16 && 0<=y && y<16){
    n=y*16+x;
    obj=document.getElementById("square"+n);
      if(flg){
        obj.src="black.png";
      }
  }
  return false;
}
</script>
<title>JavaScript研究vol.1</title>
</head>
<body>
<div id="canvas"></div>
<div id = "xy" style ="position:absolute; left:10px;top:550px;width:200px; hight:100px;background-color: #99cc00;" onmousemove="mousemove(event);">

座標</div>
<script type="text/javascript">
var x,y,n=0,tag="";
for(y=10; y<=480;y+=30){
for(x=10; x<=480; x+=30){
tag+="<img id='square"+n+"' src='white.png' style ='position:absolute; left:"+x+"px;top:"+y+"px' onMouseDown='down()' />";
n++;
}
}
document.getElementById("canvas").innerHTML=tag;
</script>
</body>
</html>

[excel VBA] 
Excel で波形データの最大値前後5件(ピンクの枠)
データを新しいシートにコピーする

1.波形データのy軸が0の位置のExcelシートの行番号を配列に格納する(min配列)

2.min配列の行データからピボットを中心に最大値の行番号を探索する

3.探索した最大値前後5件ずつ、合計10件のデータを新しいシートにコピーする

Sub test()

 Dim sRow As Long

 Dim eRow As Long

 eRow = maxV(2, minV(100, 0)) + 5

 sRow = maxV(2, minV(100, 0)) - 5

 

 Call newSheetAdd(sRow, eRow)

End Sub

 

'戻り値(min配列)を返すFunctionプロシージャ

Function minV(rlengs As Long, w As Long) As Long

 Dim s As Double

 Dim i, j, rowmin(10) As Long

 s = Cells(2, 7)

 j = 0

 For i = 3 To rlengs

  If (Cells(i, 7) = 0) Or (Cells(i, 7) = 0.1) Then

   rowmin(j) = i

   j = j + 1

   If j >= 10 Then

    Exit For

   End If

  End If

 Next i

 

 Debug.Print ("Max : " & rowmax)

 For i = 0 To 3

  Debug.Print (rowmin(i))

 Next i

 minV = rowmin(w)

End Function

’最大値の行番号を探すFunctionプロシージャ

Function maxV(start As Long, last As Long) As Long

 Dim i, rowmax, temp As Long

 Dim s As Double

 rowmax = Int((last - start) / 2)

 s = Cells(rowmax, 7)

 For i = rowmax To last

  If Cells(i, 7) > s Then

   s = Cells(i, 7)

   temp = i

  End If

 Next i

 For i = rowmax To start + 2 Step -1

  If Cells(i, 7) > s Then

   s = Cells(i, 7)

   temp = i

  End If

 Next i

 maxV = temp

 Debug.Print s & ":" & rowmax & ";"

End Function

’新しいシートに最大値から前後5件のデータをコピーする

Sub newSheetAdd(sRow As Long, eRow As Long)

 ' セル範囲を取得

 Dim selectedRange As Range

 On Error Resume Next

 Set selectedRange = Range(Cells(sRow, 6), Cells(eRow, 7))

 On Error GoTo 0

 

  ' セル範囲が選択されていない場合は終了

  If selectedRange Is Nothing Then

   MsgBox "セル範囲が選択されていません。", vbExclamation

   Exit Sub

  End If

 

' 新しいシートを作成

 Dim newSheet As Worksheet

 Set newSheet = Sheets.Add

 

' 選択したセル範囲を新しいシートにコピー

 selectedRange.Copy Destination:=newSheet.Range("A1")

 

' コピーが完了した旨のメッセージを表示

 MsgBox "セル範囲が新しいシートにコピーされました。", vbInformation

End Sub

[VBScript] 
  ファイル名を変更してファイルをコピーする

① メモ帳で以下を入力して保存「test.vbs」 拡張子は「vbs」

② "C:\Users\Owner\Pictures\images\"フォルダのpngファイルを"C:\Users\Owner\Pictures\images\test(1からの連番).png"として保存

Option Explicit

Dim objFileSys

Dim objFolder

Dim objFile

Dim objOutputTextStream

Dim strFilePathFrom

Dim strFilePathTo

Dim i

Set objFileSys = CreateObject("Scripting.FileSystemObject")

'第2引数は 1 :読み取り、2 :上書き、3 :追記。

Set objOutputTextStream = objFileSys.OpenTextFile("log.txt", 2, True)

Set objFolder = objFileSys.GetFolder("C:\Users\Owner\Pictures\images")

i = 1

For Each objFile In objFolder.Files

  objOutputTextStream.WriteLine objFile.Name

  strFilePathFrom = "C:\Users\Owner\Pictures\images\" & objFile.Name

  strFilePathTo = "C:\Users\Owner\Pictures\images\test" & CStr(i) & ".png"

  On Error Resume Next

    Call objFileSys.CopyFile(strFilePathFrom, strFilePathTo, true)

    If Err.Number <> 0 Then

      Err.Clear

    End If

 '「On Error Resume Next」を解除

  On Error Goto 0

  i = i + 1

Next

objOutputTextStream.Close

Set objOutputTextStream = Nothing

Set objFolder = Nothing

Set objFileSys = Nothing

プログラミング学習支援

©2024 プログラミング学習支援。Wix.com で作成されました。

bottom of page