VisualBasic COM Port öffnen (Kernel32 lib)

[Rexus]

Hi,

über Excel möchte ich gerne Daten von einem Messgerät anfordern und einlesen. Das Messgerät ist über einen USB-Port mit dem PC verbunden, und wird mir im Geräte-Manager unter den seriellen RS232 Schnittstellen (COM4-Port) angezeigt.
Ich bin Anfänger in Sachen VBA-Programmierung. Daher habe ich mir ein Modul zum Öffnen/Lesen/Schreiben/Schließen von COM-Ports runtergeladen, welches die Schnittstelle mit Hilfe der kernel32-Library ansteuert. Ich versuche zunächst, den COM-Port zu öffnen. Leider schlägt mein Code fehl.

Hier die relevanten Teile vom runtergeladenen ComPort-Modul:

Option explicit

Type DCB '' patched to proper definition VB32 ill-def DR
DCBlength As Long
BaudRate As Long
fdwFlags As Long ' bit field in C
wReserved1 As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As String * 1
Parity As String * 1
StopBits As String * 1
XonChar As String * 1
XoffChar As String * 1
ErrorChar As String * 1
EofChar As String * 1
EvtChar As String * 1
wReserved2 As Integer
End Type

Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type

Type COMSTAT
fCtsHold As Long
fDsrHold As Long
fRlsdHold As Long
fXoffHold As Long
fXoffSent As Long
fEof As Long
fTxim As Long
fReserved As Long
cbInQue As Long
cbOutQue As Long
End Type

'   kernel defined constants
'

Public Const OPEN_EXISTING = 3
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const INVALID_HANDLE_VALUE = &HFFFF
Public Const MAXDWORD = &HFFFF

'   comms Constants
'

Public Const PURGE_TXCLEAR = &H4
Public Const PURGE_RXCLEAR = &H8

Public Const CE_RXOVER = &H1                '  Receive Queue overflow
Public Const CE_OVERRUN = &H2 ' Receive Overrun Error
Public Const CE_RXPARITY = &H4 ' Receive Parity Error
Public Const CE_FRAME = &H8 ' Receive Framing error
Public Const CE_BREAK = &H10 ' Break Detected
Public Const CE_TXFULL = &H100              '  TX Queue is full

Public Const SETRTS = 3                     '  Set RTS high
Public Const SETDTR = 5                     '  Set DTR high


' kernel API file i/o functions
'

Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal _
lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As _
Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As _
Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As _
Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetLastError Lib "kernel32" () As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As _
Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long
Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As _
Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal _
lpOverlapped As Long) As Long

'   Win32 comms functions
'

Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB _
As DCB) As Long
Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, _
lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal _
dwFlags As Long) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal _
lpDef As String, lpDCB As DCB) As Long
Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal _
dwEvtMask As Long) As Long
Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, _
lpErrors As Long, lpStat As COMSTAT) As Long
Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal _
dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Declare Function EscapeCommFunction Lib "kernel32" (ByVal nCid As Long, _
ByVal nFunc As Long) As Long
Declare Function GetCommMask Lib "kernel32" (ByVal hFile As Long, lpEvtMask _
As Long) As Long
Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, _
lpModemStat As Long) As Long
Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, _
lpEvtMask As Long, ByVal lpOverlapped As Long) As Long


'-------------------------------------------------------------------
'
'Routine: OpenComPort
'-------------------------------------------------------------------
' Parameters : strPortName - name of the port to open
' strSettings - port settings in the format
' "baud=9600 parity=N data=8 stop=1"
' lPortHandle - set to port handle on success
' Returns : Boolean representing success
' Synopsis : opens named communications port for synchronous
' i/o. The handle returned should be used in
' subsequent calls
'
'
Public Function OpenComPort(strPortName As String, _
strSettings As String, _
lPortHandle As Long) _
                            As Boolean


Dim tCto As COMMTIMEOUTS
Dim tDcb As DCB
Dim hPort As Long
    Dim fRet    As Boolean

    '
' set the length field of the DCB
    '

    tDcb.DCBlength = Len(tDcb)

    '
' get kernel to build a default DCB for us
' based on com settings string
    '

    Call BuildCommDCB(strSettings, tDcb)

'
' open that com port
    '

    hPort = CreateFile(strPortName, _
GENERIC_READ + GENERIC_WRITE, _
0, _
0, _
OPEN_EXISTING, _
0, _
                       0)

    '
' did we get port open ...
    '

    If hPort = INVALID_HANDLE_VALUE Then

        '
' ... no, get the error code from kernel
'
Dim lErr As Long
        lErr = GetLastError()

        Debug.Print "Failed to open comport( err = " & CStr(lErr) & ")"

        '
' setup returns for failure
        '

        fRet = False
        lPortHandle = INVALID_HANDLE_VALUE

    Else

        '
' ... yes, get port ready for action
'

'
' set port state using DCB we built earlier
        '

        Call SetCommState(hPort, tDcb)

'
' set up buffer sizes and re-initialize comm driver
        '

        Call SetupComm(hPort, 64000, 64000)   ' hPort, InQue, OutQue

        '
' setup timeout parameters for this port
        '

        tCto.ReadIntervalTimeout = MAXDWORD       '' return with whatever is available
tCto.ReadTotalTimeoutMultiplier = 0
        tCto.ReadTotalTimeoutConstant = 0

        tCto.WriteTotalTimeoutMultiplier = 0
tCto.WriteTotalTimeoutConstant = 10000 '' max 10 secs to write data, just to stop locking
'' up application if we gowrong
Call SetCommTimeouts(hPort, tCto)

'
' turn on DTR / RTS
'

Call EscapeCommFunction(hPort, SETDTR)
Call EscapeCommFunction(hPort, SETRTS)

'
' setup returns for success
        '

        fRet = True
        lPortHandle = hPort

    End If

    OpenComPort = fRet

End Function

Über ein zweites Modul (das mit einem Button auf der Excel-Oberfläche verknüpft ist) rufe ich die OpenComPort-Funktion auf:

Option Explicit

Public strPortName As String
Public strSettings As String
Public lPortHandle As Long
Public OpenComPort As Boolean
Public lErr As Integer


Public Sub OpenCOM4()



strPortName = "COM4"
strSettings = "baud=115200 parity=0 data=8 stop=1"
'lPortHandle = 4
Call ComPort.OpenComPort(strPortName, strSettings, lPortHandle)

Worksheets("Tabelle1").Range("A1").Value = OpenComPort

End Sub

Die Ausgabe bzw. der Wert von OpenComPort ist FALSE.

Beim Abarbeiten bin ich inzwischen soweit gekommen:
Der CreateFile-Befehl schlägt fehl, ich erhalte bei dem Debug.Print Befehl (Line 174) folgende Fehlermeldung im VBA-Editor:

Failed to open comport ( err = 0)

Wobei der ErrorCode (angefordert über GetLastError() in Line 172) an der Stelle irgendwie nichts aussagt...?
INVALID_HANDLE_VALUE habe ich mir auch ausgeben lassen, der Wert ist "-1" (Line 181). Was bedeutet das?


Ich denke, es gilt herauszufinden, weshalb der Befehl CreateFile (Line 154) fehlschlägt. Hat jemand eine Idee?

 

[BAGZZlash]

Übergib mal "\\\\.\\COM4" (gemäß stack overflow).

 

[Rexus]

Übergib mal "\\\\.\\COM4" (gemäß stack overflow).

Danke für deine Antwort, das hatte ich sogar auch schon probiert aber leider behebt es nicht mein Problem (selber Error wie zuvor auch).

edit:

Ich habe noch das hier zum Rückgabewert der CreateFile-Funktion gefunden:

Falls das Öffnen nicht möglich war, weil die Schnittstelle nicht existiert oder bereits belegt war, ist der Rückgabewert die Konstante:
INVALID_HANDLE_VALUE =-1;

von: http://www.elektronik-labor.de/RS232/RS232_3_4.htm

Wie kann ich herausfinden, ob die Schnittstelle bereits belegt ist?
Nur weil ich das Gerät im Geräte-Manager angezeigt bekomme, ist die Schnittstelle ja nicht automatisch belegt, oder? Auch sonst greift keine Software auf das Messgerät zu.

 

[ModellbahnerTT]

Hast du die Settings auf Richtigkeit geprüft?

 

[Rexus]

Hast du die Settings auf Richtigkeit geprüft?

Danke, ja die Settings habe ich schon überprüft.

Inzwischen habe ich es hinbekommen! Ich glaube, das war mein Fehler:
Mir fiel auf, dass der Code beim ersten Mal (nachdem ich Excel gestartet habe) funktioniert. Alle weiteren Male nicht (da der Port bereits geöffnet ist, ist ein weiteres Open nicht möglich -> Ausgabe liefert False). Beim zweiten Mal Klicken auf den Open Port Button verliert er den lPortHandle (also die ID, die dem Port vom Programm zugewiesen wird). Das ist das Problem gewesen, da die Information lPortHandle benötigt wird, um den Port (mit dem selben lPortHandle-Wert) ja auch wieder zu schließen oder Daten zu lesen/zu schreiben.

Ich habe das Problem so gelöst, dass ich vor jedem Öffnen des Ports (Klick auf den Open Port Button) noch einen Close Port Befehl eingebaut habe!
Jetzt kann ich zuverlässig per Mausklick den Port öffnen, schließen, und ich habe es sogar gerade geschafft die Daten aus dem Buffer vom Messgerät auszulesen!

Hier der neue Code von OpenPort:

Sub OpenCOM4()


strPortName = "COM4"
strSettings = "baud=115200 parity=O data=8 stop=1"
'lPortHandle = 4

Call ComPort.CloseComPort(lPortHandleCOM4)

    Worksheets("Sheet1").Range("A1").Value = OpenComPort(strPortName, strSettings, lPortHandleCOM4)

End Sub

Jetzt muss ich nur noch irgendwie herausfinden, wie ich Messgerät 2 "aktivieren" kann... hier liefert OpenComPort und ReadComPort zwar jeweils TRUE zurück, aber der ausgelesene Buffer des Messgeräts bleibt leer. Wahrscheinlich ist das aber ein Problem mit dem Messgerät, dem ich irgendwie erst mitteilen muss, dass es die Messdaten aufnehmen soll. Mal schauen, wie ich es aktivieren kann.

 

[ModellbahnerTT]

Hast du keine Dokumentation zum Gerät? Dort solltest du die Daten finden die das Gerät steuern über den COMPort. Ich hoffe das du vor dem Beenden des Excel Sheets den Port wieder schließt da es sonst dazu kommt das andere Programme dann Ärger machen können weil sie eventuell nicht prüfen ob der Port belegt ist.

 

[Rexus]

Ich hoffe das du vor dem Beenden des Excel Sheets den Port wieder schließt da es sonst dazu kommt das andere Programme dann Ärger machen können weil sie eventuell nicht prüfen ob der Port belegt ist.

Danke für den Hinweis, ich werde darauf achten.

Hast du keine Dokumentation zum Gerät? Dort solltest du die Daten finden die das Gerät steuern über den COMPort.

Ich habe das Handbuch gerade im Internet gefunden.
Das Auslesen des aktuellen Messwerts ist wohl möglich, wenn man den Befehl $0R1<cr> über die RS232 Schnittstelle schickt. Als Antwort erhält man dann den aktuellen Messwert eingebettet in 0R1<value><cr>.

Ich habe schon versucht, $0R1<cr> als String über WriteFile() zu übergeben und anschließend den Messwert über ReadFile() abzugreifen (s.u.), aber es scheint wohl komplizierter zu sein. Nach Ausführen der WriteFile()-Funktion sind die Argumente nNumberOfBytesToWrite und lpNumberOfBytesWritten (siehe Link) gleich groß (genauso groß wie der String den ich schreiben möchte). Grundsätzlich liefert die Funktion aber TRUE zurück, das heißt sie wird korrekt ausgeführt.
Aber Auslesen kann ich im Anschluss nichts, es befindet sich wohl nichts im Buffer?

Sub Handshake()

 strData = "$0R1<cr>"
nNumberOfBytesToWrite = LenB(strData)
Call ComPort.WriteComPort(lPortHandleCOM4, strData, nNumberOfBytesToWrite)
strData = ""
Worksheets("Sheet1").Range("A30").Value = ReadComPort(lPortHandleCOM4, strData, cbRead)
End Sub

 

[ModellbahnerTT]

Wie lange wartetest du auf eine Antwort? Wenn du zu kurz wartest hat das Gerät noch keine Antwort gesendet.

 

[Rexus]

Wie lange wartetest du auf eine Antwort? Wenn du zu kurz wartest hat das Gerät noch keine Antwort gesendet.

Guter Ratschlag, ich habe daraufhin den Code wie folgt abgewandelt:

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

Sub Handshake()

strData = "$0R1<cr>"
cbData = LenB(strData)
Call ComPort.WriteComPort(lPortHandleCOM4, strData, cbData)
Sleep (50)
strData = ""
Worksheets("Sheet1").Range("A30").Value = ReadComPort(lPortHandleCOM4, strData, cbRead)
End Sub

Leider bekomme ich es nicht hin, dadurch eine Antwort vom Messgerät reinzuholen.


Zu dem Stichwort Sleep habe ich dann noch diesen Code in einem anderen Forum gefunden:

#If VBA7 Then ' Excel 2010 or later
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
#Else ' Excel 2007 or earlier
Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)
#End If

Public Sub SerialPort()
    ' open a COM port, transmit a message, gather results, close the port.

    ' open the COM port as file #1
Debug.Print "Open COM port 4"
    Open "COM4:115200,O,8,1" For Binary Access Read Write As #1

    transmit$ = Chr(2) + "Hello, World." + Chr(13) '"$0V<cr>" _
"$0R1<cr>"
    receiveDummy$ = ""

    ' transmit a message
Put #1, , transmit$
    Debug.Print "Message sent."

    ' wait a bit for a response
Sleep 100

' check for received message
Debug.Print "Look for incoming message."
On Error Resume Next
Do While True
receive$ = receiveDummy$ 'dummy value
Input #1, receive$
If receive$ = receiveDummy$ Then Exit Do 'the string didn't change, so move on
Debug.Print receive$
Loop
    On Error GoTo 0

    ' do it again to show that the empty input queue doesn't stop the flow
Debug.Print "Look again for incoming message (should not stop on error)."
On Error Resume Next
Do While True
receive$ = receiveDummy$ 'dummy value
Input #1, receive$
If receive$ = receiveDummy$ Then Exit Do 'the string didn't change, so move on
Debug.Print receive$
Loop
    On Error GoTo 0

    ' close the serial port
Debug.Print "Close COM port."
    Close #1

    Debug.Print "Done."
End Sub

Ich habe den Code genau so (ohne Ändern bspw. der Sleep Zeit o.Ä.) mehrfach laufen lassen und bei einigen Versuchen bekam ich eine Antwort vom Messgerät ("Failure", weil er mit dem Hello-World-String nichts anfangen kann), meistens kam aber gar keine Antwort. Wenn ich es mit den auskommentierten Codes zum Auslesen der Messdaten "$0R1<cr>" probiere, habe ich bisher noch gar keine Antwort bekommen.

Ich dachte daraufhin: Vielleicht liegt es an der Sleep Time und ich muss den Moment genau abpassen, wann eine Antwort kommt. Ich habe daraufhin eine While-Schleife drum herum gebaut und habe versucht, für jede Sleep Time 10ms <= timeToSleep <= 500ms eine Antwort zu bekommen (in 10ms Schritten). Aber leider empfange ich nichts von dem Gerät.
Hoffnung macht mir aber, dass zumindest der Fehlercode schon mal durchkam... ich bin also auf dem richtigen Weg, nur warum kann ich das Ergebnis nicht reproduzieren? Hast du vielleicht noch einen Tipp?

 

[ModellbahnerTT]

Setze sleep in Zeile 23 mal auf 200 und schau ob jedesmal eine Antwort bekommst. Wie du darauf kommst das es in 10ms dauert die while Schleife dauert entzieht sich meinen Kenntnissen? Tue allen bitte denn Gefallen und verwende keine GoTo mehr da das zu Spagetti code führt der dich in die Hölle bringen kann.

 

[BAGZZlash]

Tue allen bitte denn Gefallen und verwende keine GoTo mehr da das zu Spagetti code führt der dich in die Hölle bringen kann.

On Error GoTo 0 schaltet lediglich die Fehlerbehandlung wieder ein.

 

[Rexus]

On Error GoTo 0 schaltet lediglich die Fehlerbehandlung wieder ein.

Tatsächlich schaltet On Error GoTo 0 die Fehlerbehandlung aus, aber prinzipiell hast du Recht, es führt an der Stelle nicht zu Spaghetticode (guter Ausdruck @ModellbahnerTT ).


Inzwischen habe ich das Problem lösen können, und es war unverschämt einfach.
Statt dem String "$0R1<cr>" muss man im VBA einfach "$0R1" + vbCr eingeben, da vbCr eine Konstante für den Carriage Return ist. Mit der Übergabe war ein Auslesen des Messgeräts problemlos möglich. Das klappt sowohl mit dem Skript aus dem ersten Post, als auch mit dem Skript aus Post #9 .
Auf jeden Fall Danke an alle Beteiligten für die Ratschläge und Unterstützung bei der Lösungsfindung!

 

[BAGZZlash]

Tatsächlich schaltet On Error GoTo 0 die Fehlerbehandlung aus

Das kann man so oder so sehen: On Error Resume Next und On Error GoTo [Zeile] bewirken, dass der Programmierer auf Fehler selbst reagieren kann. On Error GoTo 0 deaktiviert dies und versetzt den Interpreter wieder in einen Zustand, in dem er sich um Fehler kümmert. In der Regel ist dies das Anzeigen einer geeigneten Fehlermeldung und anschließendes Abbrechen oder Unterbrechen des Programmflusses.

Das entwicklerdefinierte Behandeln (oder gar schlichte Nichtbehandeln im Falle von On Error Resume Next) von Fehlern wird deaktiviert und die Fehlerbehandlung wieder auf normal gestellt.

 

[ModellbahnerTT]

@BAGZZlash Danke für den Hinweis mit GoTo.