標題: 沒有設定物件變數或 With 區塊變數 [打印本頁] 作者: falsesmile777 時間: 2022-5-24 04:30 AM 標題: 沒有設定物件變數或 With 區塊變數
'*****************************************************
'* PLX-DAQ Data Acquisition for Excel "Version 2" *
'* now running with Office 32 and 64 bit *
'* *
'* Based on the PLX-DAQ from Martin Hebel *
'* optimized for 64 bit by Jonathan Arndt *
'* using the COMM port API module from David Hitchner*
'* *
'* BIG THANKS TO BOTH OF YOU FOR GREAT CODE !! :-) *
'* *
'*****************************************************
'* Programmed by: Jonathan Arndt November, 2016 *
'* arndt.jonathan@googlemail.com *
'*****************************************************
'* --------------------------------------------------*
'* "THE BEER-WARE LICENSE" (Revision 42): *
'* Net^Devil wrote this file. As long as you retain *
'* this notice you can do whatever you want with *
'* this stuff. If we meet some day, and you think *
'* this stuff is worth it, you can buy me a beer *
'* in return -- Jonathan Arndt, Stuttgart, Germany *
'* --------------------------------------------------*
'*****************************************************
'* Original remark from Martin Hebel: *
'* *
'* PLX-DAQ Data Acquisition for Excel *
'* Copyright 2007, Parallax Inc. *
'* PLX-DAQ is a trademark of Parallax, Inc. *
'* www.parallax.com *
'* Programmed by: Martin Hebel January, 2007 *
'* martin@selmaware.com *
'* Modified distribution of this macro is *
'* not permitted. Use of the SelmaDAQ Active-X *
'* control for other uses requires permission of *
'* SelmaWare Solutions - www.selmaware.com *
'*****************************************************
Dim row As Long
Dim FlagConnect As Boolean
Dim TimeStart
Dim TimeLast
Dim TimeAdd
Dim cc
Dim WStoUse As Worksheet
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 64 Bit Systems
Private Sub cboBAUD_Change()
'## Baud rate change - if already running close connection and reopen
If (FlagConnect) Then
Call CommClose(cboPort.Text)
Call CommOpen(cboPort.Text, "COM" & CStr(cboPort.Text), "baud=" & cboBAUD.Text & " parity=N data=8 stop=1")
End If
'## Port change - if already running close connection (using old port !! ) and reopen
If (FlagConnect) Then
Call CommClose(ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurPort, colSettings))
Call CommOpen(cboPort.Text, "COM" & CStr(cboPort.Text), "baud=" & cboBAUD.Text & " parity=N data=8 stop=1")
End If
Private Sub chkDTR_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurRstOnCnt, colSettings) = chkDTR.Value
End Sub
Private Sub chkReset_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurClrStdData, colSettings) = chkReset.Value
End Sub
Private Sub ChkUser1_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurUser1, colSettings) = ChkUser1.Value
End Sub
Private Sub ChkUser2_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurUser2, colSettings) = ChkUser2.Value
End Sub
Private Sub chkDump_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurDwnlData, colSettings) = chkDump.Value
End Sub
Private Sub cmdDebugWindow_Click()
If (cmdDebugWindow.Caption = "Display direct debug =>") Then
frmStampDAQ.Width = 470
cmdDebugWindow.Caption = "<= Hide direct debug"
Else
frmStampDAQ.Width = 220
cmdDebugWindow.Caption = "Display direct debug =>"
End If
End Sub
Private Sub optBtnUse1WS_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCur1WS, colSettings) = optBtnUse1WS.Value
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurActWS, colSettings) = optBtnUseActWS.Value
End Sub
Private Sub optBtnUseActWS_Click()
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCur1WS, colSettings) = optBtnUse1WS.Value
ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurActWS, colSettings) = optBtnUseActWS.Value
End Sub
Private Sub cmdClear_Click()
Call clearSheet
End Sub
On Error GoTo ConnectErr
Dim lngStatus As Long
Dim strError As String
Dim strData As String
Dim target As String, buffer As String
target = ""
buffer = ""
'#### Open Port
lngStatus = CommOpen(cboPort.Text, "COM" & CStr(cboPort.Text), "baud=" & cboBAUD.Text & " parity=N data=8 stop=1")
'# check for error
If (lngStatus <> 0) Then
lngStatus = CommGetError(strError)
MsgBox "COM Error: " & strError & vbNewLine & vbNewLine & "Aborting!", vbOKCancel + vbCritical, "Error open port"
cmdConnect.Caption = "Connect"
cmdConnect.BackColor = &H8000000F
Exit Sub
End If
If (CBool(chkDTR)) Then
lngStatus = CommSetLine(cboPort.Text, LINE_RTS, True)
lngStatus = CommSetLine(cboPort.Text, LINE_DTR, True)
End If
If (optBtnUse1WS.Value) Then
Set WStoUse = ThisWorkbook.Sheets(1)
Else
Set WStoUse = ThisWorkbook.ActiveSheet
End If
'## to prevent rubbish characters before first CLEARDATA ;; I know it is dirty ...
CommFlush (cboPort.Text)
Sleep (100) ' seems to work Application.Wait (Now + TimeValue("0:00:01"))
CommFlush (cboPort.Text)
'#### Endless data loop while connected to read data and pass to DataReady function
Do While (FlagConnect = True)
DoEvents
lngStatus = CommRead(cboPort.Text, strData, 64)
If lngStatus > 0 Then
'Build up buffer
buffer = buffer & strData
'Until vbCrLf is found (Carriage return Line Feed, thus a line break) and then split
If (InStr(1, buffer, vbCrLf, vbBinaryCompare) >= 1) Then
target = Left(buffer, InStr(1, buffer, vbCrLf, vbBinaryCompare) - 1)
buffer = Mid(buffer, InStr(1, buffer, vbCrLf, vbBinaryCompare) + Len(vbCrLf))
Call DataReady(target)
txtDirectText.Text = target & vbNewLine & txtDirectText.Text
End If
ConnectErr:
Call MsgBox("Could not connect." & vbCrLf & "Please check port settings", vbExclamation)
End Sub
Private Sub DataReady(data As String)
On Error GoTo Data_Error
Dim DataVal() As String
If data <> "" Then
DataVal = Split(data, ",")
Select Case DataVal(0)
Case "CMD?"
txtStatus2 = "Stamp requesting instruction..."
If chkDump.Value = True Then
CommWrite cboPort.Text, "11"
Exit Sub
End If
If chkReset = True Then
CommWrite cboPort.Text, "22"
Exit Sub
End If
Case "LABEL"
cc = countChar(data, ",")
txtStatus2 = "Setting labels"
For X = 1 To cc Mod 27
WStoUse.Range(Chr(64 + X) & CStr(1)).Value = ReplaceData(DataVal(X))
Next
row = 1
Case "DATA"
cc = countChar(data, ",")
row = row + 1
txtStatus2 = "Accepting data for Row " & (row - 1)
For X = 1 To cc Mod 27
WStoUse.Range(Chr(64 + X) & CStr(row)).Value = ReplaceData(DataVal(X))
Next
Case "CELL"
Select Case DataVal(1)
Case "GET"
CommWrite cboPort.Text, WStoUse.Range(DataVal(2)).Value
txtStatus2 = "Getting Cell " & DataVal(2)
Case "SET"
WStoUse.Range(DataVal(2)).Value = ReplaceData(DataVal(3))
txtStatus2 = "Setting Cell " & DataVal(3)
End Select
Case "USER1"
Select Case DataVal(1)
Case "SET"
ChkUser1.Value = CBool(Val(DataVal(2)))
txtStatus2 = "Setting " & ChkUser1.Caption
Case "GET"
CommWrite cboPort.Text, CStr(Abs(CInt(ChkUser1.Value)))
txtStatus2 = "Getting " & ChkUser1.Caption
Case "LABEL"
ChkUser1.Caption = DataVal(2)
End Select
Case "USER2"
Select Case DataVal(1)
Case "SET"
ChkUser2.Value = CBool(Val(DataVal(2)))
txtStatus2 = "Setting " & ChkUser2.Caption
Case "GET"
CommWrite cboPort.Text, CStr(Abs(CInt(ChkUser3.Value)))
txtStatus2 = "Getting " & ChkUser2.Caption
Case "LABEL"
ChkUser2.Caption = DataVal(2)
End Select
Case "DOWNLOAD"
Select Case DataVal(1)
Case "SET"
chkDump.Value = CBool(Val(DataVal(2)))
txtStatus2 = "Setting " & chkDump.Caption
Case "GET"
CommWrite cboPort.Text, CStr(Abs(CInt(chkDump.Value)))
txtStatus2 = "Getting " & chkDump.Caption
Case "LABEL"
chkDump.Caption = DataVal(2)
End Select
Case "STORED"
Select Case DataVal(1)
Case "SET"
chkReset.Value = CBool(Val(DataVal(2)))
txtStatus2 = "Setting " & chkReset.Caption
Case "GET"
CommWrite cboPort.Text, CStr(Abs(CInt(chkReset.Value)))
txtStatus2 = "Getting " & chkReset.Caption
Case "LABEL"
chkReset.Caption = DataVal(2)
End Select
Case "ROW"
Select Case DataVal(1)
Case "SET"
row = Val(DataVal(2)) - 1
txtStatus2 = "Setting Row"
Case "GET"
CommWrite cboPort.Text, CStr(row)
End Select
End Select
End If
Exit Sub
Data_Error:
End Sub
Private Sub clearSheet() WStoUse.Range("A2:" & Split(WStoUse.UsedRange.Address, ":", , vbBinaryCompare)(1)).Value = Null
row = 1
End Sub
Private Function countChar(stringIn As String, stringChar As String)
For X = 1 To Len(stringIn)
If Mid(stringIn, X, 1) = stringChar Then
countChar = countChar + 1
End If
Next
End Function
Private Function ReplaceData(strData)
If Timer < TimeLast Then
If TimeAdd = 0 Then
TimeAdd = (86400# - TimeStart)
Else
TimeAdd = TimeAdd + 86400#
End If
TimeStart = 0
End If
prevPort = ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurPort, colSettings)
If (IsNumeric(prevPort)) Then
cboPort.Text = IIf(prevPort > 0 And prevPort < 16, prevPort, 1)
Else
cboPort.Text = 1
End If
prevBaud = ThisWorkbook.Sheets(SettingsSheet).Cells(rowCurBaud, colSettings)
If (IsNumeric(prevBaud)) Then
cboBAUD.Text = IIf(prevBaud <> 300 And prevBaud <> 600 And prevBaud <> 1200 And prevBaud <> 2400 _
And prevBaud <> 4800 And prevBaud <> 9600 And prevBaud <> 14400 And prevBaud <> 19200 And prevBaud <> 28800 _
And prevBaud <> 38400 And prevBaud <> 56000 And prevBaud <> 128000 _
And prevBaud <> 230400 And prevBaud <> 250000, 9600, prevBaud)
Else
cboBAUD.Text = 9600
End If