| Excel VBA page |
VBAプログラムの紹介
| Excel VBA page |
エクセルシート上で「メソッド」のような働きをもたせるために作成した、VBAプログラムのソースを公開しておきます。 （セルに下記の文字列を記入すると、そのセルをクリックした時にプログラムが動作する仕組み） ※GPIB関連のプログラムは、National Instruments社の公開している、NIGLOBALモジュールとVBIB32モジュールが必要になります。 | |
up, down ： セルの数値を↑↓キーで増減させる s_paste_d, s_paste_r ： コピーされた内容を、下側（右側）のセルに数値として貼り付ける execute ： 列挙したセルに書かれているメソッドを、上から順番に動作させてゆく copy_d, copy_r ： 下側（右側）にあるセルをコピーする clear ： 指定したセルの内容をクリアする apply ： 指定したセルに、文字列や数値を上書きさせる startFFT ： 指定した範囲のデータを用いて、フーリエ変換を実行する writeG, write ： GPIB機器にコマンドを送り、返ってきた信号を受信する writeOnly ： GPIB機器にコマンドを送る（受信はしない） open ： GPIB機器との通信を開始する（連続動作のために使用） close ： GPIB機器との通信を終了する read ： GPIB機器から信号を受信する Tstart ： タイマーを使って、指定した時間おきにコマンドを実行させる Tstop ： タイマー動作を途中で中断する wait ： 指定した時間だけプログラムの動作をフリーズさせる | |
(up/downのみ) | Option Explicit Private Sub Worksheet_SelectionChange(ByVal target As Range) If target.Count > 1 Then Exit Sub On Error GoTo a If target.Value = "" Then Exit Sub checkTarget target a: End Sub Private Sub checkTarget(target As Range) If target.Value = "" Then Exit Sub If target.Value = "up" Then updown target.Row + 1, target.Column, 1 If target.Value = "down" Then updown target.Row - 1, target.Column, -1 End Sub Private Sub updown(r As Integer, c As Integer, sign As Integer) Cells(r - 2, c) = Cells(r - 2, c) + sign * Cells(r, c) Cells(r, c).Select End Sub |
(全て) | Option Explicit Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Dim TimerFlag As Boolean Dim prev As Long Dim interval As Long Dim current As Long Dim GPIBadd As Integer Dim cmd As String Dim rdst As String * 60 Dim ud(20) As Integer Const timeout = T300ms Private Sub Worksheet_SelectionChange(ByVal target As Range) If target.Count > 1 Then Exit Sub On Error GoTo a If target.value = "" Then Exit Sub checkTarget target, True a: End Sub Private Sub checkTarget(target As Range, moveflag As Boolean) If target.value = "" Then Exit Sub If target.value = "up" Then updown target.Row + 1, target.Column, 1, moveflag If target.value = "down" Then updown target.Row - 1, target.Column, -1, moveflag If target.value = "s_paste_d" Then special_paste target.Row + 1, target.Column If target.value = "s_paste_r" Then special_paste target.Row, target.Column + 1 If target.value = "execute" Then execute target.Row, target.Column, moveflag If target.value = "copy_d" Then copy_all target.Row + 1, target.Column, xlDown, moveflag If target.value = "copy_r" Then copy_all target.Row, target.Column + 1, xlToRight, moveflag If target.value = "clear" Then clear target.Row + 1, target.Column, moveflag If target.value = "apply" Then apply target.Row + 1, target.Column, moveflag If target.value = "startFFT" Then FFT target.Row, target.Column If target.value = "writeG" Then talk target.Row, target.Column, True, False, True, moveflag If target.value = "write" Then talk target.Row, target.Column, True, True, False, moveflag If target.value = "writeOnly" Then talk target.Row, target.Column, True, False, False, moveflag If target.value = "open" Then openclose target.Row, target.Column, True, moveflag If target.value = "close" Then openclose target.Row, target.Column, False, moveflag If target.value = "read" Then talk target.Row, target.Column, False, True, False, moveflag If target.value = "Tstart" Then timer_start target.Row, target.Column, moveflag If target.value = "Tstop" Then timer_stop target.Row, target.Column, moveflag If target.value = "wait" Then waits target.Row, target.Column, moveflag End Sub Private Sub updown(r As Integer, c As Integer, sign As Integer, moveflag As Boolean) Cells(r - 2, c) = Cells(r - 2, c) + sign * Cells(r, c) If moveflag = True Then Cells(r, c).Select End Sub Private Sub special_paste(r As Integer, c As Integer) Cells(r, c).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End Sub Private Sub execute(r As Integer, c As Integer, moveflag As Boolean) Dim i As Integer For i = 1 To Cells(r + 1, c) checkTarget Range(Cells(r + 1 + i, c)), False Next If moveflag = True Then Cells(r + 1, c).Select End Sub Private Sub copy_all(r As Integer, c As Integer, xlto As Integer, moveflag As Boolean) Range(Cells(r, c), Cells(r, c).End(xlto)).Copy End Sub Private Sub clear(r As Integer, c As Integer, moveflag As Boolean) 'If MsgBox("Clear OK?", vbOKCancel, "clear") = vbCancel Then Exit Sub Range(Cells(r, c)).ClearContents If moveflag = True Then Cells(r, c).Select End Sub Private Sub apply(r As Integer, c As Integer, moveflag As Boolean) Range(Cells(r, c)) = Cells(r + 1, c) If moveflag = True Then Cells(r, c).Select End Sub Private Sub FFT(r As Integer, c As Integer) Cells(r, c).value = "wait" Application.Run "ATPVBAEN.XLA!Fourier", Range(Cells(r + 1, c)), Range(Cells(r + 2, c)), False, False Range(Cells(r + 2, c)).Font.Size = 9 Cells(r, c).value = "startFFT" Cells(r + 1, c).Select End Sub Private Sub timer_start(r As Integer, c As Integer, moveflag As Boolean) prev = GetTickCount TimerFlag = True If Cells(r + 3, c) = "on" Then Cells(r + 1, c) = 0 If Cells(r + 7, c) <> "" Then checkTarget Range(Cells(r + 7, c)), False 'before exe. If moveflag = True Then Cells(r + 1, c).Select Do While TimerFlag = True interval = Cells(r + 5, c) '途中でスピードを変えられる current = GetTickCount If current - prev > interval Then If Cells(r + 8, c) <> "" Then checkTarget Range(Cells(r + 8, c)), False 'every exe. If Cells(r + 9, c) <> "" Then Cells(r + 15 + Cells(r + 1, c), c) = Val(Range(Cells(r + 9, c))) '測定値をコピー Cells(r + 1, c) = Cells(r + 1, c) + 1 'Current numberを+1 Cells(r + 6, c) = current - prev prev = current If Cells(r + 1, c) = Val(Cells(r + 4, c).value) Then If Cells(r + 10, c) <> "" Then checkTarget Range(Cells(r + 10, c)), False 'after exe. If Cells(r + 3, c) = "off" Then Cells(r + 1, c) = 0 TimerFlag = False checkTarget Range(Cells(r + 11, c)), False '次のtimerをstart End If End If DoEvents Loop End Sub Private Sub waits(r As Integer, c As Integer, moveflag As Boolean) Dim s As Integer s = Cells(r + 1, c) Sleep s If moveflag = True Then Cells(r + 1, c).Select End Sub Private Sub timer_stop(r As Integer, c As Integer, moveflag As Boolean) If Cells(r + 8, c) <> "" Then checkTarget Range(Cells(r + 8, c)), False 'after exe. TimerFlag = False If moveflag = True Then Cells(r - 1, c).Select End Sub Private Sub openclose(r As Integer, c As Integer, openFlag As Boolean, moveflag As Boolean) GPIBadd = Cells(r + 1, c) If openFlag = True Then Call ibdev(0, GPIBadd, 0, timeout, 1, 1, ud(GPIBadd)) Else Call ibonl(ud(GPIBadd), 0) End If If moveflag = True Then Cells(r + 1, c).Select End Sub Private Sub talk(r As Integer, c As Integer, writeFlag As Boolean, readFlag As Boolean, GFlag As Boolean, moveflag As Boolean) GPIBadd = Cells(r + 1, c) cmd = Cells(r + 2, c) rdst = "" Dim uds As Integer If TimerFlag = True Then uds = ud(GPIBadd) If TimerFlag = False Then Call ibdev(0, GPIBadd, 0, timeout, 1, 1, uds) If writeFlag = True Then Call ibwrt(uds, cmd) If GFlag = True Then Call ibwrt(uds, "G:") If readFlag = True Then Call ibrd(uds, rdst) If TimerFlag = False Then Call ibonl(uds, 0) If Trim(rdst) <> "" Then Cells(r + 3, c) = rdst End If If moveflag = True Then Cells(r + 1, c).Select End Sub |