'-------------------------------------------------------------------------------
Private Type COMM_ERROR lngErrorCode As Long strFunction As String strErrorMessage As String End Type
Private Type COMM_PORT lngHandle As Long
blnPortOpen As Boolean udtDCB As DCB End Type
'------------------------------------------------------------------------------- ' Program Storage
'-------------------------------------------------------------------------------
Private udtCommOverlap As OVERLAPPED Private udtCommError As COMM_ERROR
Private udtPorts(1 To MAX_PORTS) As COMM_PORT
'------------------------------------------------------------------------------- ' GetSystemMessage - Gets system error text for the specified error code.
'------------------------------------------------------------------------------- Public Function GetSystemMessage(lngErrorCode As Long) As String Dim intPos As Integer
Dim strMessage As String, strMsgBuff As String * 256
Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, lngErrorCode, 0, strMsgBuff, 255, 0)
intPos = InStr(1, strMsgBuff, vbNullChar) If intPos > 0 Then
strMessage = Trim$(Left$(strMsgBuff, intPos - 1)) Else
strMessage = Trim$(strMsgBuff) End If
GetSystemMessage = strMessage
End Function
Public Function PauseApp(PauseInSeconds As Long)
Call AppSleep(PauseInSeconds * 1000)
End Function
'-------------------------------------------------------------------------------
' CommOpen - Opens/Initializes serial port. ' '
' Parameters:
' intPortID - Port ID used when port was opened.
' strPort - COM port name. (COM1, COM2, COM3, COM4) ' strSettings - Communication settings.
' Example: \'
' Returns:
' Error Code - 0 = No Error. '
'------------------------------------------------------------------------------- Public Function CommOpen(intPortID As Integer, strPort As String, _ strSettings As String) As Long
Dim lngStatus As Long
Dim udtCommTimeOuts As COMMTIMEOUTS
On Error GoTo Routine_Error
' See if port already in use.
If udtPorts(intPortID).blnPortOpen Then lngStatus = -1 With udtCommError
.lngErrorCode = lngStatus .strFunction = \
.strErrorMessage = \ End With
GoTo Routine_Exit End If
' Open serial port.
udtPorts(intPortID).lngHandle = CreateFile(strPort, GENERIC_READ Or _ GENERIC_WRITE, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If udtPorts(intPortID).lngHandle = -1 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
udtPorts(intPortID).blnPortOpen = True
' Setup device buffers (1K each).
lngStatus = SetupComm(udtPorts(intPortID).lngHandle, 1024, 1024)
If lngStatus = 0 Then
lngStatus = SetCommError(\
GoTo Routine_Exit End If
' Purge buffers.
lngStatus = PurgeComm(udtPorts(intPortID).lngHandle, PURGE_TXABORT Or _ PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
' Set serial port timeouts. With udtCommTimeOuts
.ReadIntervalTimeout = -1
.ReadTotalTimeoutMultiplier = 0 .ReadTotalTimeoutConstant = 1000 .WriteTotalTimeoutMultiplier = 0 .WriteTotalTimeoutMultiplier = 1000 End With
lngStatus = SetCommTimeouts(udtPorts(intPortID).lngHandle, udtCommTimeOuts)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
' Get the current state (DCB).
lngStatus = GetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
' Modify the DCB to reflect the desired settings.
lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
' Set the new state.
lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
lngStatus = 0
Routine_Exit:
CommOpen = lngStatus Exit Function
Routine_Error:
lngStatus = Err.Number With udtCommError
.lngErrorCode = lngStatus .strFunction = \
.strErrorMessage = Err.Description End With
Resume Routine_Exit End Function
Private Function SetCommError(strFunction As String) As Long
With udtCommError
.lngErrorCode = Err.LastDllError .strFunction = strFunction
.strErrorMessage = GetSystemMessage(.lngErrorCode) SetCommError = .lngErrorCode End With
End Function
Private Function SetCommErrorEx(strFunction As String, lngHnd As Long) As Long Dim lngErrorFlags As Long Dim udtCommStat As COMSTAT
With udtCommError
.lngErrorCode = GetLastError .strFunction = strFunction
.strErrorMessage = GetSystemMessage(.lngErrorCode)
Call ClearCommError(lngHnd, lngErrorFlags, udtCommStat)
.strErrorMessage = .strErrorMessage & \ Hex$(lngErrorFlags)
SetCommErrorEx = .lngErrorCode End With
End Function
'------------------------------------------------------------------------------- ' CommSet - Modifies the serial port settings. '
' Parameters:
' intPortID - Port ID used when port was opened. ' strSettings - Communication settings.
' Example: \'
' Returns:
' Error Code - 0 = No Error.
'------------------------------------------------------------------------------- Public Function CommSet(intPortID As Integer, strSettings As String) As Long
Dim lngStatus As Long
On Error GoTo Routine_Error
lngStatus = GetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB)
If lngStatus = 0 Then
lngStatus = SetCommError(\ GoTo Routine_Exit End If
lngStatus = 0
Routine_Exit:
CommSet = lngStatus Exit Function