'utiliser le port de communication RS 232
'commentaires anglo/néerlandais
' code de Rody Meulman, posté sur mpep
' (non testé, fs)
'nécessite le composant ActiveX "mscomm32.ocx" correctement enregistré
Dim MSComm1 As Object
Dim bInitComGlobals As Boolean
Sub InitComGlobals()
If Not bInitComGlobals Then
On Error Resume Next
Set MSComm1 = CreateObject("MSCOMMLib.MSComm")
If Err.Number <> 0 Then
MsgBox Err.Description & vbLf & "Bitte installieren Sie" & "MSCOMM32.OCX!", _
vbMsgBoxHelpButton, "Fehler beim Aufruf von MSComm", Err.HelpFile, Err.HelpContext
End
Else
bInitComGlobals = True
End If
On Error GoTo 0
End If
End Sub
Function CommPortOpen(nPort As Integer, nBaudRate As Long) As Boolean
InitComGlobals
MSComm1.CommPort = nPort
On Error Resume Next
MSComm1.PortOpen = True
If Err = 0 Then
CommPortOpen = True
MSComm1.Settings = nBaudRate & ",N,8,1"
Else
CommPortOpen = False
Err = 0
End If
On Error GoTo 0
End Function
Sub CommPortClose()
If bInitComGlobals Then
If MSComm1.PortOpen Then
MSComm1.PortOpen = False
Set MSComm1 = Nothing
bInitComGlobals = False
End If
End If
End Sub
'\----------------------------------------------------------------------------
'\ SerialWrite sends a string to the current comm port
'\ Return 0, wenn OK
'\ Fehler-Nummer bei Fehler
Function SerialWrite(T$) As Integer
'\On Error Resume Next
MSComm1.Output = T
SerialWrite = Err
End Function
'\----------------------------------------------------------------------------
'\ SerialWait waits for a number of seconds (Wait) for a user-indicated string
'\ of characters (waitstr$) OR WaitStr2. It then stuffs the comm buffer into buf$ and returns
'\ TRUE if it finds the string, or FALSE otherwise.
Function SerialWait(buf$, Wait As Double, waitstr$, Optional WaitStr2) As Boolean
Dim B$, Start, bStatusbar, bFound As Boolean, bStr2 As Boolean
Start = Timer '\ Set start time.
bStr2 = Not IsMissing(WaitStr2)
If bStr2 Then bStr2 = Application.IsText(WaitStr2)
buf$ = ""
bStatusbar = Application.StatusBar
If bStatusbar = False Then Application.StatusBar = "Lese von ..."
' Wait for data to come back to the serial port.
MSComm1.InputLen = 1 '\ nur immer 1 Byte lesen
Do: DoEvents
buf$ = buf$ & MSComm1.Input
bFound = InStr(buf$, waitstr$) > 0
If bStr2 Then bFound = bFound Or (InStr(buf$, WaitStr2) > 0)
Loop Until bFound Or (Timer - Start > Wait)
SerialWait = bFound
If bStatusbar = False Then Application.StatusBar = False
End Function
'\----------------------------------------------------------------------------
'\ SerialCheck waits for the number of bytes in the comm-buffer
'\ max. 2 sec
'\ BUT read NOT
'\ return: True or False (bei Timeout )
Function serialCheck(nBytes) As Boolean
Dim bTimeout As Boolean, Start
Start = Timer
Do: DoEvents: bTimeout = Timer - Start > 2
Loop Until MSComm1.InBufferCount >= nBytes Or bTimeout
If bTimeout Then serialCheck = False Else serialCheck = True
End Function
'\----------------------------------------------------------------------------
'\ SerialRead waits for the number of bytes in the comm-buffer
'\ and read then
Function SerialRead(nBytes, buf$) As Integer
Dim B$, nRead%, bStatusbar
bStatusbar = Application.StatusBar
If bStatusbar = False Then Application.StatusBar = "Lese von ..."
SerialRead = 0
MSComm1.InputLen = nBytes '\ nur nBytes lesen
serialCheck (nBytes) '\ Warten bis nBytes imm Puffer (bei Timeout ebenfalls lesen)
buf$ = MSComm1.Input
SerialRead = Len(buf$)
If bStatusbar = False Then Application.StatusBar = False
End Function
