Dim BaseColor As Long
Dim talker As Long, stbyte As Long, nP As Integer
Dim TimerCount As Single, FLG As Integer, nCycle As Integer
Dim ScaleH As Single, ScaleW As Single, FileName As String, Ans As Integer
Dim Xmin As Single, Xmax As Single, Ymin As Single, Ymax As Single
Dim Cmd(31) As Long, CmdR(31) As Long
Dim Pstb(31) As Long ' 返送されたステータスバイト配列
Dim temp As String * 1000, t(50000) As Single, Tem(50000) As Single
Dim AdrComp As Integer, Adr2000 As Integer
　Private Sub Form_Load()
　Form2.Show
　AdrComp = 0 ' Computer Address
　Adr2000 = 7 ' Model 2000 Multimeter Address
　nP = 10
'----------------------------------------------------------------------------
　e1 = GpIni(): 'GPIB 初期化
　e2 = GpIfc(1): 'インターフェイスクリア (1×100μsec)
　e3 = GpRen(): 'GPIB remote enable
　e4 = GpDelim(1, 1): 'Delimiter [1: CR+LF / 1: EOI valid]
　e5 = GpTimeout(2000): 'Timeout (2000×1msec)
　e6 = GpSdc(Adr2000): 'SDC (Select Device Clear)
　If e1 <> 0 Then Form2.Text1.Text = "GP-IB intialization Failed" Else Form2.Text1.Text = "GP-IB intialization OK"
　If e2 <> 0 Then Form2.Text2.Text = "Interface Clear Failed" Else Form2.Text2.Text = "Interface Clear OK"
　If e3 <> 0 Then Form2.Text3.Text = "GP-IB Remote Enable Failed" Else Form2.Text3.Text = "GP-IB Remote Enable OK"
　If e4 <> 0 Then Form2.Text4.Text = "Delimiter Failed" Else Form2.Text4.Text = "Delimiter OK"
　If e5 <> 0 Then Form2.Text5.Text = "Timeout (2sec) Failed" Else Form2.Text5.Text = "Timeout (2msec) OK"
　If e6 <> 0 Then Form2.Text6.Text = "Select Device Clear Failed" Else Form2.Text6.Text = "Select Device Clear OK"
'----------------------------------------------------------------------
　e7 = GpCrst(Adr2000): 'Reset Model 2000 (*RST)
　e8 = GpCcls(Adr2000): 'Clear Status (*CLS)
　If e7 <> 0 Then Form2.Text7.Text = "Reset Model 2000 Failed" Else Form2.Text7.Text = "Reset Model 2000 OK"
　L = Len(Str(nP))
' *** Set up trigger model ***
　Cmd(0) = 2 'talker + listener
　Cmd(1) = AdrComp 'talker address (GPIB)
　Cmd(2) = Adr2000 'listener address(Model 2000)
　e9 = GpTalk(Cmd(0), 19, ":INIT:CONT 0;:ABORT") 'Reset trigger mode
　e10 = GpTalk(Cmd(0), 13, ":SAMP:COUNT 1") 'Sample Count 1
　e11 = GpTalk(Cmd(0), 14, ":TRIG:SOUR IMM") 'Measure immediate
　e12 = GpTalk(Cmd(0), 10 + L, ":TRIG:COUN" + Str$(nP)) 'Measure nP points
　If e9 <> 0 Then Form2.Text9.Text = "Reset Trigger Mode Failed" Else Form2.Text9.Text = "Reset Trigger Mode OK"
　If e10 <> 0 Then Form2.Text10.Text = "Sample Count Failed" Else Form2.Text10.Text = "Sample Count OK"
　If e11 <> 0 Then Form2.Text11.Text = "Measure Immediate Failed" Else Form2.Text11.Text = "Measure Immediate OK"
　If e12 <> 0 Then Form2.Text12.Text = "Measure DATA Points Failed" Else Form2.Text12.Text = "Measure DATA points OK"
' *** Set up Buffer ***
　e13 = GpTalk(Cmd(0), 12, ":TRACE:CLEAR") 'Clear Buffer
　e14 = GpTalk(Cmd(0), 10 + L, ":TRAC:POIN" + Str$(nP)) 'Store nP points
　e15 = GpTalk(Cmd(0), 16, ":FORM:DATA ASCII") 'ASCII data
　e16 = GpTalk(Cmd(0), 15, ":FORM:ELEM READ") 'Readings only
　e17 = GpTalk(Cmd(0), 20, ":TRAC:FEED:CONT NEXT") 'Fill and stop
　If e13 <> 0 Then Form2.Text13.Text = "Clear Buffer Failed" Else Form2.Text13.Text = "Clear Buffer OK"
　If e14 <> 0 Then Form2.Text14.Text = "Store DATA Points Failed" Else Form2.Text14.Text = "Store DATA Pointrs OK"
　If e15 <> 0 Then Form2.Text15.Text = "Ascii DATA Failed" Else Form2.Text15.Text = "Ascii DATA OK"
　If e16 <> 0 Then Form2.Text16.Text = "Readings only Failed" Else Form2.Text16.Text = "Readings only OK"
　If e17 <> 0 Then Form2.Text17.Text = "Fill and stop Failed" Else Form2.Text17.Text = "Fill and Stop OK"
' *** Set up function parameters ***
　e = GpTalk(Cmd(0), 17, ":SENS:FUNC 'TEMP'") '温度
'　 e = GpTalk(Cmd(0), 12, ":UNIT:TEMP C") '（℃）
　e = GpTalk(Cmd(0), 15, ":TEMP:TC:TYPE K") 'Thermocouple Type K
　e = GpTalk(Cmd(0), 12, ":TEMP:NPLC 1") 'Sampling Speed (Med）0.01->10
' 　e = GpTalk(Cmd(0), 14, ":TEMP:NPLC 0.1") 'Sampling Speed (Fast）0.01->10
' 　e = GpTalk(Cmd(0), 12, ":TEMP:NPLC 5") 'Sampling Speed (Slow）0.01->10
' *** Set up SRQ on buffer full ***
　e18 = GpTalk(Cmd(0), 19, ":STAT:MEAS:ENAB 512") 'SRQ buf full
　e19 = GpCsre(Adr2000, 1) 'Turn on srq (*SRE)
　If e18 <> 0 Then Form2.Text18.Text = "SRQ Buffer Full Failed" Else Form2.Text18.Text = "SRQ Buffer Full OK"
　If e19 <> 0 Then Form2.Text19.Text = "Turn on SRQ Failed" Else Form2.Text19.Text = "Turn on SRQ OK"
' *** Start meaurements ***
　e20 = GpTalk(Cmd(0), 5, ":INIT") 'Start measurements
　If e20 <> 0 Then Form2.Text20.Text = "INIT Failed" Else Form2.Text20.Text = "INIT OK"
' *** Wait for SRQ ***
　Cmd(0) = 1 ' トーカ数
　Cmd(1) = Adr2000 ' トーカアドレス
　e21 = GpPoll(Cmd(0), Pstb(0)) ' ポーリング
　talker = Cmd(Pstb(0)) '
　stbyte = Pstb(Pstb(0)) ' RQSビットONのトーカを発見した配列番号
　If e21 <> 0 Then Form2.Text21.Text = "Polling Failed => " & e21 Else Form2.Text21.Text = "Polling OK"
' *** Send stored data ***
　Cmd(0) = 2 'talker + listener
　Cmd(1) = AdrComp 'talker address (GPIB)
　Cmd(2) = Adr2000 'listener address (Model 2000)
　e22 = GpTalk(Cmd(0), 11, ":TRAC:DATA?") 'Read stored data
　If e22 <> 0 Then Form2.Text22.Text = "Read Stroed DATA Failed" Else Form2.Text22.Text = "Read Stored DATA OK"
　CmdR(0) = 2 'talker + listener
　CmdR(1) = Adr2000 'talker address (Model 2000)
　CmdR(2) = AdrComp 'listener address (GPIB)
　e23 = GpListen(CmdR(0), 16 * nP, temp)
　If e23 <> 0 Then Form2.Text23.Text = "Read Failed => " & e23 Else Form2.Text23.Text = "Read OK"
'----------------------------------------------
　n = 1
　For I = 1 To nP
　　buf$ = Mid$(temp, n, 15)
　　n = n + 16
　Next I
　Tem(0) = Val(buf$)
　t(0) = 0#
　Text5.Text = Val(buf$)
'-----------------------------------
　Cmd(0) = 2 'talker + listener
　Cmd(1) = AdrComp 'talker address (GPIB)
　Cmd(2) = Adr2000 'listener address (Model 2000)
　e24 = GpTalk(Cmd(0), 16, ":STAT:MEAS:EVEN?") 'Clear status
　If e24 <> 0 Then Form2.Text24.Text = "Clear Status Failed" Else Form2.Text24.Text = "Clear Status OK"
'-----------------------------------------------------
　e = GpResetren()
　Timer1.Interval = 100 ' (100 msec)
　Timer1.Enabled = False
　ScaleH = 100: ScaleW = 2000
　BaseColor = Command2.BackColor
　Command3.Enabled = False
End Sub

Private Sub Command2_Click()
　Command2.Enabled = False
　Command3.Enabled = True
　Command2.BackColor = vbGreen
　Command3.BackColor = BaseColor
　Xmin = Val(Text6.Text)
　Xmax = Val(Text7.Text)
　Ymin = Val(Text3.Text)
　Ymax = Val(Text2.Text)
　e = GpRen() ' GPIB remote enable
　FLG = 0
　If Val(Text4.Text) <= 0 Then
　　Beep
　　e = MsgBox("Sampling time < 0", vbOKOnly, "警告")
　　Exit Sub
　End If
　If Xmax <= Xmin Then
　　Beep
　　e = MsgBox("Xmin > Xmax", vbOKOnly, "警告")
　　Exit Sub
　End If
　If Ymax <= Ymin Then
　　Beep
　　e = MsgBox("Ymin > Ymax", vbOKOnly, "警告")
　　Exit Sub
　End If
　Picture1.Cls
'--------------------------------------------------
　nCycle = 1
　Open "A:\User\abe\project_VB\Keithley_Model2000\dummy.dat" For Output As #2

　　Do
　　　Call Meas

　　　If t(nCycle - 1) > Xmax * 0.95 Then
　　　　Xmax = Xmax * 5#
　　　　Text7.Text = Xmax
　　　　Picture1.Cls
　　　　For I = 1 To nCycle - 1
　　　　　X1 = (t(I - 1) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　X2 = (t(I) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　Y1 = ScaleH - (Tem(I - 1) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Y2 = ScaleH - (Tem(I) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Picture1.Line (X1, Y1)-(X2, Y2), 6
　　　　Next I
　　　End If
　　　If Tem(nCycle - 1) > Ymax Then
　　　　Ymax = Tem(nCycle)
　　　　Text2.Text = Ymax
　　　　Picture1.Cls
　　　　For I = 1 To nCycle - 1
　　　　　X1 = (t(I - 1) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　X2 = (t(I) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　Y1 = ScaleH - (Tem(I - 1) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Y2 = ScaleH - (Tem(I) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Picture1.Line (X1, Y1)-(X2, Y2), 6
　　　　Next I
　　　End If
　　　If Tem(nCycle - 1) < Ymin Then
　　　　Ymin = Tem(nCycle)
　　　　Text3.Text = Ymin
　　　　Picture1.Cls
　　　　For I = 1 To nCycle - 1
　　　　　X1 = (t(I - 1) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　X2 = (t(I) - Xmin) / (Xmax - Xmin) * ScaleW
　　　　　Y1 = ScaleH - (Tem(I - 1) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Y2 = ScaleH - (Tem(I) - Ymin) / (Ymax - Ymin) * ScaleH
　　　　　Picture1.Line (X1, Y1)-(X2, Y2), 6
　　　　Next I
　　　End If
　　　If FLG = 1 Then Exit Do
　　Loop
　Close #2
　e = GpResetren()
　Command2.Enabled = True
End Sub

Private Sub Command3_Click()
　FLG = 1
　Command3.BackColor = vbRed
　Command2.BackColor = BaseColor
　Beep
　e = MsgBox("データを保存しますか？", vbYesNo, "確認")
　If e = 6 Then
　　On Error Resume Next
　　CommonDialog1.CancelError = True
　　CommonDialog1.Filter = "データファイル(*.dat)|*.dat|" & "すべてのファイル(*.*)|*.*|"
　　CommonDialog1.FilterIndex = 1
　　CommonDialog1.DefaultExt = "dat"
　　CommonDialog1.ShowSave
　　FileName = CommonDialog1.FileName
　　If Err.Number = cdlCancel Then
　　　Exit Sub
　　Else
　　　If Dir(FileName) <> "" Then Ans = MsgBox("上書きしますか？", vbYesNo, "確認")
　　　If Ans = vbNo Then Exit Sub
　　End If

　　Open FileName For Output As #1
　　　For k = 1 To nCycle
　　　　Print #1, t(k), Tem(k)
　　　Next k
　　　Beep
　　　MsgBox (FileName & " 保存しました")
　　Close #1
　End If
　Command3.Enabled = False
　Call Meas
End Sub

Private Sub Meas()
　Cmd(0) = 2 'talker + listener
　Cmd(1) = AdrComp 'talker address (GPIB)
　Cmd(2) = Adr2000 'listener address(Model 2000)
　e9 = GpTalk(Cmd(0), 19, ":INIT:CONT 0;:ABORT") 'Reset trigger mode
　e13 = GpTalk(Cmd(0), 12, ":TRACE:CLEAR") 'Clear Buffer
　e16 = GpTalk(Cmd(0), 15, ":FORM:ELEM READ") 'Readings only
　e17 = GpTalk(Cmd(0), 20, ":TRAC:FEED:CONT NEXT") 'Fill and stop
　e19 = GpCsre(Adr2000, 1) 'Turn on srq (*SRE)
　e20 = GpTalk(Cmd(0), 5, ":INIT") 'Start measurements
　e22 = GpTalk(Cmd(0), 11, ":TRAC:DATA?") 'Read stored data

　CmdR(0) = 2 'talker + listener
　CmdR(1) = Adr2000 'talker address (Model 2000)
　CmdR(2) = AdrComp 'listener address (GPIB)
　e23 = GpListen(CmdR(0), 16 * nP, temp)
'----------------------------------------------
　n = 1
　For I = 1 To nP
　　t(nCycle) = t(nCycle - 1) + Val(Text4.Text) / nP
　　buf$ = Mid$(temp, n, 15)
　　Tem(nCycle) = Val(buf$)
　　Print #2, t(nCycle), Tem(nCycle)
　　X1 = (t(nCycle - 1) - Xmin) / (Xmax - Xmin) * ScaleW
　　X2 = (t(nCycle) - Xmin) / (Xmax - Xmin) * ScaleW
　　Y1 = ScaleH - (Tem(nCycle - 1) - Ymin) / (Ymax - Ymin) * ScaleH
　　Y2 = ScaleH - (Tem(nCycle) - Ymin) / (Ymax - Ymin) * ScaleH
　　Picture1.Line (X1, Y1)-(X2, Y2), 6
　　nCycle = nCycle + 1
　　n = n + 16
　Next I
　Text5.Text = Val(buf$)
　Text1.Text = t(nCycle - 1)
　Call delay(Val(Text4.Text)) ' Sampling time
End Sub

Private Sub delay(TimeData)
　TimerCount = 0
　Timer1.Enabled = True
　Do While TimeData >= TimerCount
　　DoEvents
　Loop
　Timer1.Enabled = False
End Sub

Private Sub form_unload(cancel As Integer)
　Unload Form2
　e = GpResetren()
　e = GpExit()
End Sub

Private Sub Timer1_Timer()
　TimerCount = TimerCount + 0.1 ' (0.1 sec)
End Sub