VBA-中使用-API-串口通信-Serial-Port-(英文).docx

- This VB module is a collection of routines to perform serial port I/O without using the Microsoft Comm Control component. This module uses the Windows API to perform the overlapped I/O operations necessary for serial communications. The routine can handle up to 4 serial ports which are identified with a Port ID. All routines (with the exception of CommRead and CommWrite) return an error code or 0 if no error occurs. The routine CommGetError can be used to get the complete error message.- Public Constants- Output Control Lines (CommSetLine)Const LINE_BREAK = 1Const LINE_DTR = 2Const LINE_RTS = 3 Input Control Lines (CommGetLine)Const LINE_CTS = &H10&Const LINE_DSR = &H20&Const LINE_RING = &H40&Const LINE_RLSD = &H80&Const LINE_CD = &H80&- System Constants-Private Const ERROR_IO_INCOMPLETE = 996&Private Const ERROR_IO_PENDING = 997Private Const GENERIC_READ = &H80000000Private Const GENERIC_WRITE = &H40000000Private Const FILE_ATTRIBUTE_NORMAL = &H80Private Const FILE_FLAG_OVERLAPPED = &H40000000Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000Private Const OPEN_EXISTING = 3 COMM FunctionsPrivate Const MS_CTS_ON = &H10&Private Const MS_DSR_ON = &H20&Private Const MS_RING_ON = &H40&Private Const MS_RLSD_ON = &H80&Private Const PURGE_RXABORT = &H2Private Const PURGE_RXCLEAR = &H8Private Const PURGE_TXABORT = &H1Private Const PURGE_TXCLEAR = &H4 COMM Escape FunctionsPrivate Const CLRBREAK = 9Private Const CLRDTR = 6Private Const CLRRTS = 4Private Const SETBREAK = 8Private Const SETDTR = 5Private Const SETRTS = 3- System Structures-Private Type COMSTAT fBitFields As Long See Comment in Win32API.Txt cbInQue As Long cbOutQue As LongEnd TypePrivate Type COMMTIMEOUTS ReadIntervalTimeout As Long ReadTotalTimeoutMultiplier As Long ReadTotalTimeoutConstant As Long WriteTotalTimeoutMultiplier As Long WriteTotalTimeoutConstant As LongEnd Type The DCB structure defines the control setting for a serial communications device.Private Type DCB DCBlength As Long BaudRate As Long fBitFields As Long See Comments in Win32API.Txt wReserved As Integer XonLim As Integer XoffLim As Integer ByteSize As Byte Parity As Byte StopBits As Byte XonChar As Byte XoffChar As Byte ErrorChar As Byte EofChar As Byte EvtChar As Byte wReserved1 As Integer Reserved; Do Not UseEnd TypePrivate Type OVERLAPPED Internal As Long InternalHigh As Long offset As Long OffsetHigh As Long hEvent As LongEnd TypePrivate Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As LongEnd Type- System Functions- Fills a specified DCB structure with values specified in a device-control string.Private Declare Function BuildCommDCB Lib kernel32 Alias BuildCommDCBA _ (ByVal lpDef As String, lpDCB As DCB) As Long Retrieves information about a communications error and reports the current status of a communications device. The function is called when a communications error occurs, and it clears the devices error flag to enable additional input and output (I/O) operations.Private Declare Function ClearCommError Lib kernel32 _ (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long Closes an open communications device or file handle.Private Declare Function CloseHandle Lib kernel32 (ByVal hObject As Long) As Long Creates or opens a communications resource and returns a handle that can be used to access the resource.Private Declare Function CreateFile Lib kernel32 Alias CreateFileA _ (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, lpSecurityAttributes As Any, _ ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long) As Long Directs a specified communications device to perform a function.Private Declare Function EscapeCommFunction Lib kernel32 _ (ByVal nCid As Long, ByVal nFunc As Long) As Long Formats a message string such as an error string returned by anoher function.Private Declare Function FormatMessage Lib kernel32 Alias FormatMessageA _ (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _ ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _ Arguments As Long) As Long Retrieves modem control-register values.Private Declare Function GetCommModemStatus Lib kernel32 _ (ByVal hFile As Long, lpModemStat As Long) As Long Retrieves the current control settings for a specified communications device.Private Declare Function GetCommState Lib kernel32 _ (ByVal nCid As Long, lpDCB As DCB) As Long Retrieves the calling threads last-error code value.Private Declare Function GetLastError Lib kernel32 () As Long Retrieves the results of an overlapped operation on the specified file, named pipe, or communications device.Private Declare Function GetOverlappedResult Lib kernel32 _ (ByVal hFile As Long, lpOverlapped As OVERLAPPED, _ lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long Discards all characters from the output or input buffer of a specified communications resource. It can also terminate pending read or write operations on the resource.Private Declare Function PurgeComm Lib kernel32 _ (ByVal hFile As Long, ByVal dwFlags As Long) As Long Reads data from a file, starting at the position indicated by the file pointer. After the read operation has been completed, the file pointer is adjusted by the number of bytes actually read, unless the file handle is created with the overlapped attribute. If the file handle is created for overlapped input and output (I/O), the application must adjust the position of the file pointer after the read operation.Private Declare Function ReadFile Lib kernel32 _ (ByVal hFile As Long, ByVal lpBuffer As String, _ ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, _ lpOverlapped As OVERLAPPED) As Long Configures a communications device according to the specifications in a device-control block (a DCB structure). The function reinitializes all hardware and control settings, but it does not empty output or input queues.Private Declare Function SetCommState Lib kernel32 _ (ByVal hCommDev As Long, lpDCB As DCB) As Long Sets the time-out parameters for all read and write operations on a specified communications device.Private Declare Function SetCommTimeouts Lib kernel32 _ (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long Initializes the communications parameters for a specified communications device.Private Declare Function SetupComm Lib kernel32 _ (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long Writes data to a file and is designed for both synchronous and a synchronous operation. The function starts writing data to the file at the position indicated by the file pointer. After the write operation has been completed, the file pointer is adjusted by the number of bytes actually written, except when the file is opened with FILE_FLAG_OVERLAPPED. If the file handle was created for overlapped input and output (I/O), the application must adjust the position of the file pointer after the write operation is finished.Private Declare Function WriteFile Lib kernel32 _ (ByVal hFile As Long, ByVal lpBuffer As String, _ ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _ lpOverlapped As OVERLAPPED) As LongPrivate Declare Sub AppSleep Lib kernel32 Alias Sleep (ByVal dwMilliseconds As Long)- Program Constants-Private Const MAX_PORTS = 4- Program Structures-Private Type COMM_ERROR lngErrorCode As Long strFunction As String strErrorMessage As StringEnd TypePrivate Type COMM_PORT lngHandle As Long blnPortOpen As Boolean udtDCB As DCBEnd Type - Program Storage-Private udtCommOverlap As OVERLAPPEDPrivate udtCommError As COMM_ERRORPrivate 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 StringDim intPos As IntegerDim 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 FunctionPublic 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: baud=9600 parity=N data=8 stop=1 Returns: Error Code - 0 = No Error.-Public Function CommOpen(intPortID As Integer, strPort As String, _ strSettings As String) As Long Dim lngStatus As LongDim 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 = CommOpen .strErrorMessage = Port in use. 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(CommOpen (CreateFile) 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(CommOpen (SetupComm) 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(CommOpen (PurgeComm) 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(CommOpen (SetCommTimeouts) GoTo Routine_Exit End If Get the current state (DCB). lngStatus = GetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB) If lngStatus = 0 Then lngStatus = SetCommError(CommOpen (GetCommState) 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(CommOpen (BuildCommDCB) GoTo Routine_Exit End If Set the new state. lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB) If lngStatus = 0 Then lngStatus = SetCommError(CommOpen (SetCommState) GoTo Routine_Exit End If lngStatus = 0Routine_Exit: CommOpen = lngStatus Exit FunctionRoutine_Error: lngStatus = Err.Number With udtCommError .lngErrorCode = lngStatus .strFunction = CommOpen .strErrorMessage = Err.Description End With Resume Routine_ExitEnd FunctionPrivate Function SetCommError(strFunction As String) As Long With udtCommError .lngErrorCode = Err.LastDllError .strFunction = strFunction .strErrorMessage = GetSystemMessage(.lngErrorCode) SetCommError = .lngErrorCode End With End FunctionPrivate Function SetCommErrorEx(strFunction As String, lngHnd As Long) As LongDim lngErrorFlags As LongDim udtCommStat As COMSTAT With udtCommError .lngErrorCode = GetLastError .strFunction = strFunction .strErrorMessage = GetSystemMessage(.lngErrorCode) Call ClearCommError(lngHnd, lngErrorFlags, udtCommStat) .strErrorMessage = .strErrorMessage & COMM Error Flags = & _ 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: baud=9600 parity=N data=8 stop=1 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(CommSet (GetCommState) GoTo Routine_Exit End If lngStatus = BuildCommDCB(strSettings, udtPorts(intPortID).udtDCB) If lngStatus = 0 Then lngStatus = SetCommError(CommSet (BuildCommDCB) GoTo Routine_Exit End If lngStatus = SetCommState(udtPorts(intPortID).lngHandle, _ udtPorts(intPortID).udtDCB) If lngStatus = 0 Then lngStatus = SetCommError(CommSet (SetCommState) GoTo Routine_Exit End If lngStatus = 0Routine_Exit: CommSet = lngStatus Exit FunctionRoutine_Error: lngStatus = Err.Number With udtCommError .lngErrorCode = lngStatus .strFunction = CommSet .strErrorMessage = Err.Description End With Resume Routine_ExitEnd Function- CommClose - Close the serial port. Parameters: intPortID - Port ID used when port was opened. Returns: Error Code - 0 = No Error.-Public Function CommClose(intPortID As Integer) As Long Dim lngStatus As Long On Error GoTo Routine_Error If udtPorts(intPortID).blnPortOpen Then lngStatus = CloseHandle(udtPorts(intPortID).lngHandle) If lngStatus = 0 Then lngStatus = SetCommError(CommClose (CloseHandle) GoTo Routine_Exit End If udtPorts(intPortID).blnPortOpen = False End If lngStatus = 0Routine_Exit: CommClose = lngStatus Exit FunctionRoutine_Error: lngStatus = Err.Number With udtCommError .lngErrorCode = lngStatus .strFunction = CommClose .strErrorMessage = Err.Description End