- '* ******************************************************* *
- '* 程序名称:basComm.bas
- '* 程序功能:在VB中利用API进行串口通信
- '* 作者:lyserver
- '* 联系方式:http://blog.csdn.net/lyserver
- '* ******************************************************* *
- Option Explicit
- Option Base 0
- Private 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
- Private 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
- Private 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
- Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
- Private Const GENERIC_READ = &H80000000
- Private Const GENERIC_WRITE = &H40000000
- Private Const OPEN_EXISTING = 3
- Private Const INVALID_HANDLE_VALUE = -1
- Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
- Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
- Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
- Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
- Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
- Private Const PURGE_TXABORT = &H1 ' Kill the pending/current writes to the comm port.
- Private Const PURGE_RXABORT = &H2 ' Kill the pending/current reads to the comm port.
- Private Const PURGE_TXCLEAR = &H4 ' Kill the transmit queue if there.
- Private Const PURGE_RXCLEAR = &H8 ' Kill the typeahead buffer if there.
- 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 Use
- End Type
- Private Type COMMTIMEOUTS
- ReadIntervalTimeout As Long
- ReadTotalTimeoutMultiplier As Long
- ReadTotalTimeoutConstant As Long
- WriteTotalTimeoutMultiplier As Long
- WriteTotalTimeoutConstant As Long
- End Type
- Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
- '串口操作演示
- Sub Main()
- Dim hComm As Long
- Dim szTest As String
-
- '打开串口1
- hComm = OpenComm(1)
-
- If hComm <> 0 Then
- '设置串口通讯参数
- SetCommParam hComm
-
- '设置串口超时
- SetCommTimeOut hComm, 2, 3
-
- '向串口写入字符串123
- szTest = "123"
- WriteComm hComm, StringToBytes(szTest)
-
- '读串口
- szTest = BytesToString(ReadComm(hComm))
- Debug.Print szTest
-
- '关闭串口
- CloseComm hComm
- End If
- End Sub
- '打开串口
- Function OpenComm(ByVal lComPort As Long) As Long
- Dim hComm As Long
-
- hComm = CreateFile("COM" & lComPort, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
- If hComm = INVALID_HANDLE_VALUE Then
- OpenComm = 0
- Else
- OpenComm = hComm
- End If
- End Function
- '关闭串口
- Sub CloseComm(hComm As Long)
- CloseHandle hComm
- hComm = 0
- End Sub
- '读串口
- Function ReadComm(ByVal hComm As Long) As Byte()
- Dim dwBytesRead As Long
- Dim BytesBuffer() As Byte
-
- ReDim BytesBuffer(4095)
- ReadFile hComm, BytesBuffer(0), UBound(BytesBuffer) + 1, dwBytesRead, 0
- If dwBytesRead > 0 Then
- ReDim Preserve BytesBuffer(dwBytesRead)
- ReadComm = BytesBuffer
- End If
- End Function
- '写串口
- Function WriteComm(ByVal hComm As Long, BytesBuffer() As Byte) As Long
- Dim dwBytesWrite
-
- If SafeArrayGetDim(BytesBuffer) = 0 Then Exit Function
- WriteFile hComm, BytesBuffer(0), UBound(BytesBuffer) + 1, dwBytesWrite, 0
- WriteComm = dwBytesWrite
- End Function
- '设置串口通讯参数
- Function SetCommParam(ByVal hComm As Long, Optional ByVal lBaudRate As Long = 9600, _
- Optional ByVal cByteSize As Byte = 8, Optional ByVal cStopBits As Byte = 0, _
- Optional ByVal cParity As Byte = 0, Optional ByVal cEOFChar As Long = 26) As Boolean
-
- Dim dc As DCB
- If hComm = 0 Then Exit Function
-
- If GetCommState(hComm, dc) Then
- dc.BaudRate = lBaudRate
- dc.ByteSize = cByteSize
- dc.StopBits = cStopBits
- dc.Parity = cParity
- dc.EOFChar = cEOFChar
-
- SetCommParam = CBool(SetCommState(hComm, dc))
- End If
- End Function
- '设置串口超时
- Function SetCommTimeOut(ByVal hComm As Long, Optional ByVal dwReadTimeOut As Long = 2, _
- Optional ByVal dwWriteTimeOut As Long = 3) As Boolean
-
- Dim ct As COMMTIMEOUTS
- If hComm = 0 Then Exit Function
-
- ct.ReadIntervalTimeout = dwReadTimeOut '读操作时,字符间超时
- ct.ReadTotalTimeoutMultiplier = dwReadTimeOut '读操作时,每字节超时
- ct.ReadTotalTimeoutConstant = dwReadTimeOut '读操作时,固定超时(总超时=每字节超时*字节数+固定超时)
- ct.WriteTotalTimeoutMultiplier = dwWriteTimeOut '写操作时,每字节超时
- ct.WriteTotalTimeoutConstant = dwWriteTimeOut '写操作时,固定超时(总超时=每字节超时*字节数+固定超时)
-
- SetCommTimeOut = CBool(SetCommTimeouts(hComm, ct))
- End Function
- '设置串口读写缓冲区大小
- Function SetCommBuffer(ByVal hComm As Long, Optional ByVal dwBytesRead As Long = 1024, _
- Optional ByVal dwBytesWrite As Long = 512) As Boolean
-
- If hComm = 0 Then Exit Function
- SetCommBuffer = CBool(SetupComm(hComm, dwBytesRead, dwBytesWrite))
- End Function
- '清空串口缓冲区
- Sub ClearComm(ByVal hComm As Long, Optional ByVal InBuffer As Boolean = True, Optional ByVal OutBuffer As Boolean = True)
- If hComm = 0 Then Exit Sub
- If InBuffer And OutBuffer Then '清空输入输出缓冲区
- PurgeComm hComm, PURGE_TXABORT Or PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR
- ElseIf InBuffer Then '清空输入缓冲区
- PurgeComm hComm, PURGE_RXABORT Or PURGE_RXCLEAR
- ElseIf OutBuffer Then '清空输出缓冲区
- PurgeComm hComm, PURGE_TXABORT Or PURGE_TXCLEAR
- End If
- End Sub
- '辅助函数:BSTR字符串转换为CHAR字符串
- Function StringToBytes(ByVal szText As String) As Byte()
- If Len(szText) > 0 Then
- StringToBytes = StrConv(szText, vbFromUnicode)
- End If
- End Function
- '辅助函数:CHAR字符串转换为BSTR字符串
- Function BytesToString(bytesText() As Byte) As String
- If SafeArrayGetDim(bytesText) <> 0 Then
- BytesToString = StrConv(bytesText, vbUnicode)
- End If
- End Function
- '辅助函数:获得CHAR字符串长度
- Function Byteslen(bytesText() As Byte) As Long
- If SafeArrayGetDim(bytesText) <> 0 Then
- Byteslen = UBound(bytesText) + 1
- End If
- End Function