VB的MSCOMM控件虽然很好用,但是在没有装VB的机器上用该控件总觉得有些累赘,网上的VB API代码大部分都基于是同步方式,处理复杂的通信模式不是太理想,所以用了一些时间,把VC项目中的异步串口读写代码翻译为VB格式。
![](https://p-blog.csdn.net/images/p_blog_csdn_net/yefanqiu/YF060817001.jpg)
在VB新建一个类,把下面的代码复制后即可使用
'
*************************************************************************
' **模 块 名:SerialPort
' **说 明:YFsoft 版权所有2006 - 2007(C)
' **创 建 人:叶帆
' **日 期:2006-08-17 14:32:29
' **修 改 人:
' **日 期:
' **描 述:串口异步读写(API)
' **版 本:V1.0.0
' *************************************************************************
Option Explicit
Private 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
Private Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type
Private Type DCB
DCBlength As Long
BaudRate As Long
' DWORD DCBlength; /* sizeof(DCB) */
' DWORD BaudRate; /* Baudrate at which running */
' DWORD fBinary: 1; /* Binary Mode (skip EOF check) */
' DWORD fParity: 1; /* Enable parity checking */
' DWORD fOutxCtsFlow:1; /* CTS handshaking on output */
' DWORD fOutxDsrFlow:1; /* DSR handshaking on output */
' DWORD fDtrControl:2; /* DTR Flow control */
' DWORD fDsrSensitivity:1; /* DSR Sensitivity */
' DWORD fTXContinueOnXoff: 1; /* Continue TX when Xoff sent */
' DWORD fOutX: 1; /* Enable output X-ON/X-OFF */
' DWORD fInX: 1; /* Enable input X-ON/X-OFF */
' DWORD fErrorChar: 1; /* Enable Err Replacement */
' DWORD fNull: 1; /* Enable Null stripping */
' DWORD fRtsControl:2; /* Rts Flow control */
' DWORD fAbortOnError:1; /* Abort all reads and writes on Error */
' DWORD fDummy2:17; /* Reserved */
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 OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CloseHandle Lib " kernel32 " ( ByVal hObject As Long ) As Long
Private Declare Function GetLastError Lib " kernel32 " () As Long
Private Declare Function ReadFile Lib " kernel32 " ( ByVal hFile As Long , lpBuffer As Any, ByVal nNumberOfBytesToRead As Long , lpNumberOfBytesRead As Long , lpOverlapped As OVERLAPPED) As Long
Private Declare Function WriteFile Lib " kernel32 " ( ByVal hFile As Long , lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long , lpNumberOfBytesWritten As Long , lpOverlapped As OVERLAPPED) As Long ' OVERLAPPED
Private Declare Function SetCommTimeouts Lib " kernel32 " ( ByVal hFile As Long , lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetCommTimeouts Lib " kernel32 " ( ByVal hFile As Long , lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function BuildCommDCB Lib " kernel32 " Alias " BuildCommDCBA " ( ByVal lpDef As String , lpDCB As DCB) As Long
Private Declare Function SetCommState Lib " kernel32 " ( ByVal hCommDev As Long , lpDCB As DCB) As Long
Private Declare Function GetCommState Lib " kernel32 " ( ByVal nCid As Long , lpDCB As DCB) As Long
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 FlushFileBuffers Lib " kernel32 " ( ByVal hFile As Long ) As Long
Private Declare Function CreateEvent Lib " kernel32 " Alias " CreateEventA " (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long , ByVal bInitialState As Long , ByVal lpName As String ) As Long
Private Declare Function SetCommMask Lib " kernel32 " ( ByVal hFile As Long , ByVal dwEvtMask As Long ) As Long
Private Declare Function SetEvent Lib " kernel32 " ( ByVal hEvent As Long ) As Long
Private Declare Function PurgeComm Lib " kernel32 " ( ByVal hFile As Long , ByVal dwFlags As Long ) As Long
Private Declare Function ClearCommError Lib " kernel32 " ( ByVal hFile As Long , lpErrors As Long , lpStat As ComStat) As Long
Private Declare Function GetOverlappedResult Lib " kernel32 " ( ByVal hFile As Long , lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long , ByVal bWait As Long ) As Long
Private Declare Function WaitForSingleObject Lib " kernel32 " ( ByVal hHandle As Long , ByVal dwMilliseconds As Long ) As Long
Private Declare Function SetupComm Lib " kernel32 " ( ByVal hFile As Long , ByVal dwInQueue As Long , ByVal dwOutQueue As Long ) As Long
Private Const GENERIC_WRITE = & H40000000
Private Const GENERIC_READ = & H80000000
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = & H80
Private Const FILE_FLAG_OVERLAPPED = & H40000000
Private Const DTR_CONTROL_DISABLE = & H0
Private Const RTS_CONTROL_ENABLE = & H1
Private Const PURGE_RXABORT = & H2
Private Const PURGE_RXCLEAR = & H8
Private Const PURGE_TXABORT = & H1
Private Const PURGE_TXCLEAR = & H4
Private Const ERROR_IO_PENDING = 997
Private Const STATUS_WAIT_0 = & H0
Private Const WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0 )
Private Const WAIT_TIMEOUT = 258 &
Private m_Handle As Long
Private m_OverlappedRead As OVERLAPPED
Private m_OverlappedWrite As OVERLAPPED
' *************************************************************************
' **函 数 名:OpenPort
' **输 入:ComNumber(Long) - 串口号
' ** :Comsettings(String) - 配置信息
' **输 出:(Long) - 0 成功 非 0 失败
' **功能描述:打开串口
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:40:14
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function OpenPort(ComNumber As Long , Comsettings As String , Optional lngInSize As Long = 1024 , Optional lngOutSize As Long = 512 ) As Long
On Error GoTo handelinitcom
Dim retval As Long
Dim CtimeOut As COMMTIMEOUTS, dcbs As DCB
Dim strCOM As String , strConfig As String
strCOM = " /.COM " & Format (ComNumber, " 0 " )
m_Handle = CreateFile(strCOM, GENERIC_READ Or GENERIC_WRITE, 0 , 0 & , OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0 )
If m_Handle = - 1 Then
OpenPort = - 1
Exit Function
End If
' 设置dcb块
dcbs.DCBlength = Len (dcbs) ' 长度
Call GetCommState(m_Handle, dcbs)
' 波特率,奇偶校验,数据位,停止位 如:9600,n,8,1
strConfig = " COM " & Format (ComNumber, " 0 " ) & " : " & Comsettings
Call BuildCommDCB(strConfig, dcbs)
' ------------------------------
' dcbs.fBinary = 1 '二进制方式
' dcbs.fOutxCtsFlow = 0 '不用CTS检测发送流控制
' dcbs.fOutxDsrFlow = 0 '不用DSR检测发送流控制
' dcbs.fDtrControl = DTR_CONTROL_DISABLE '禁止DTR流量控制
' dcbs.fDsrSensitivity = 0 '对DTR信号线不敏感
' dcbs.fTXContinueOnXoff = 1 '检测接收缓冲区
' dcbs.fOutX = 0 '不做发送字符控制
' dcbs.fInX = 0 '不做接收控制
' dcbs.fErrorChar = 0 '是否用指定字符替换校验错的字符
' dcbs.fNull = 0 '保留NULL字符
' dcbs.fRtsControl = RTS_CONTROL_ENABLE '允许RTS流量控制
' dcbs.fAbortOnError = 0 '发送错误后,继续进行下面的读写操作
' dcbs.fDummy2 = 0 '保留
dcbs.fBitFields = 1 * 2 ^ 0 Or DTR_CONTROL_DISABLE * 2 ^ 4 Or 1 * 2 ^ 7 Or RTS_CONTROL_ENABLE * 2 ^ 12
dcbs.wReserved = 0 ' 没有使用,必须为0
dcbs.XonLim = 0 ' 指定在XOFF字符发送之前接收到缓冲区中可允许的最小字节数
dcbs.XoffLim = 0 ' 指定在XOFF字符发送之前缓冲区中可允许的最小可用字节数
dcbs.XonChar = 0 ' 发送和接收的XON字符
dcbs.XoffChar = 0 ' 发送和接收的XOFF字符
dcbs.ErrorChar = 0 ' 代替接收到奇偶校验错误的字符
dcbs.EofChar = 0 ' 用来表示数据的结束
dcbs.EvtChar = 0 ' 事件字符,接收到此字符时,会产生一个事件
' dcbs.wReserved1 = 0 '没有使用
' dcbs.BaudRate =9600 '波特率
' dcbs.Parity=0 '奇偶校验
' dcbs.ByteSize=8 '数据位
' dcbs.StopBits=0 '停止位
' ------------------------------
If dcbs.Parity = 0 Then ' 0-4=None,Odd,Even,Mark,Space
dcbs.fBitFields = dcbs.fBitFields And & HFFFD ' dcbs.fParity = 0 '奇偶校验无效
Else
dcbs.fBitFields = dcbs.fBitFields Or & H2 ' dcbs.fParity = 1 '奇偶校验有效
End If
' 超时设置
CtimeOut.ReadIntervalTimeout = 20 ' 0
CtimeOut.ReadTotalTimeoutConstant = 1 ' 2500
CtimeOut.ReadTotalTimeoutMultiplier = 1 ' 0
CtimeOut.WriteTotalTimeoutConstant = 10 ' 2500
CtimeOut.WriteTotalTimeoutMultiplier = 1 ' 0
retval = SetCommTimeouts(m_Handle, CtimeOut)
If retval = - 1 Then
retval = GetLastError()
OpenPort = retval
retval = CloseHandle(m_Handle)
Exit Function
End If
' 获取信号句柄
Dim lpEventAttributes1 As SECURITY_ATTRIBUTES
Dim lpEventAttributes2 As SECURITY_ATTRIBUTES
m_OverlappedRead.hEvent = CreateEvent(lpEventAttributes1, 1 , 0 , 0 )
m_OverlappedWrite.hEvent = CreateEvent(lpEventAttributes2, 1 , 0 , 0 )
' 判断设置参数是否成功 设置输入和输出缓冲区是否成功
If SetCommState(m_Handle, dcbs) = - 1 Or SetupComm(m_Handle, lngInSize, lngOutSize) = - 1 Or m_OverlappedRead.hEvent = 0 Or m_OverlappedWrite.hEvent = 0 Then
retval = GetLastError()
OpenPort = retval
If (m_OverlappedRead.hEvent <> 0 ) Then CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0 ) Then CloseHandle (m_OverlappedWrite.hEvent)
Call CloseHandle(m_Handle)
m_Handle = 0
Exit Function
End If
OpenPort = 0
Exit Function
handelinitcom:
Call CloseHandle(m_Handle)
m_Handle = 0
OpenPort = - 2
Exit Function
End Function
' *************************************************************************
' **函 数 名:ClosePort
' **输 入:无
' **输 出:(Long) - 0 成功 -1 失败
' **功能描述:关闭串口
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:56:13
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClosePort() As Long
If (m_Handle = 0 ) Then
ClosePort = 1
Exit Function
End If
Call SetCommMask(m_Handle, 0 )
Call SetEvent(m_OverlappedRead.hEvent)
Call SetEvent(m_OverlappedWrite.hEvent)
If (m_OverlappedRead.hEvent <> 0 ) Then CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0 ) Then CloseHandle (m_OverlappedWrite.hEvent)
If CloseHandle(m_Handle) <> 0 Then
ClosePort = 0
Else
ClosePort = - 1
End If
m_Handle = 0
End Function
' *************************************************************************
' **函 数 名:ClearInBuf
' **输 入:无
' **输 出:无
' **功能描述:清空输入缓冲区
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:57:26
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClearInBuf() As Long
If (m_Handle = 0 ) Then
ClearInBuf = 1
Exit Function
End If
Call PurgeComm(m_Handle, PURGE_RXABORT Or PURGE_RXCLEAR)
ClearInBuf = 0
End Function
' *************************************************************************
' **函 数 名:ClearOutBuf
' **输 入:无
' **输 出:(Long) -
' **功能描述:清空输出缓冲区
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 15:40:38
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClearOutBuf() As Long
If (m_Handle = 0 ) Then
ClearOutBuf = 1
Exit Function
End If
Call PurgeComm(m_Handle, PURGE_TXABORT Or PURGE_TXCLEAR)
ClearOutBuf = 0
End Function
' *************************************************************************
' **函 数 名:SendData
' **输 入:bytBuffer()(Byte) - 数据
' ** :lngSize(Long) - 数据长度
' **输 出:(Long) -
' **功能描述:发送数据
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 15:43:42
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function SendData(bytBuffer() As Byte , lngSize As Long ) As Long
On Error GoTo ToExit ' 打开错误陷阱
' ------------------------------------------------
If (m_Handle = 0 ) Then
SendData = 1
Exit Function
End If
Dim dwBytesWritten As Long
Dim bWriteStat As Long
Dim ComStats As ComStat
Dim dwErrorFlags As Long
dwBytesWritten = lngSize
Call ClearCommError(m_Handle, dwErrorFlags, ComStats)
bWriteStat = WriteFile(m_Handle, bytBuffer( 0 ), lngSize, dwBytesWritten, m_OverlappedWrite)
If bWriteStat = 0 Then
If GetLastError() = ERROR_IO_PENDING Then
Call GetOverlappedResult(m_Handle, m_OverlappedWrite, dwBytesWritten, 1 ) ' 等待直到发送完毕
End If
Else
dwBytesWritten = 0
End If
SendData = dwBytesWritten
' ------------------------------------------------
Exit Function
' ----------------
ToExit:
SendData = - 1
End Function
' *************************************************************************
' **函 数 名:ReadData
' **输 入:bytBuffer()(Byte) - 数据
' ** :lngSize(Long) - 数据长度
' **输 出:(Long) -
' **功能描述:读取数据
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 16:04:38
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ReadData(bytBuffer() As Byte , lngSize As Long , Optional Overtime As Long = 3000 ) As Long
On Error GoTo ToExit ' 打开错误陷阱
' ------------------------------------------------
If (m_Handle = 0 ) Then
ReadData = 1
Exit Function
End If
Dim lngBytesRead As Long
Dim fReadStat As Long
Dim dwRes As Long
lngBytesRead = lngSize
' 读数据
fReadStat = ReadFile(m_Handle, bytBuffer( 0 ), lngSize, lngBytesRead, m_OverlappedRead)
If fReadStat = 0 Then
If GetLastError() = ERROR_IO_PENDING Then ' 重叠 I/O 操作在进行中
dwRes = WaitForSingleObject(m_OverlappedRead.hEvent, Overtime) ' 等待,直到超时
Select Case dwRes
Case WAIT_OBJECT_0: ' 读完成
If GetOverlappedResult(m_Handle, m_OverlappedRead, lngBytesRead, 0 ) = 0 Then
' 错误
ReadData = - 2
Exit Function
End If
Case WAIT_TIMEOUT: ' 超时
ReadData = - 1
Exit Function
Case Else : ' WaitForSingleObject 错误
End Select
End If
End If
ReadData = lngBytesRead
' ------------------------------------------------
Exit Function
' ----------------
ToExit:
ReadData = - 1
End Function
' *************************************************************************
' **函 数 名:Class_Terminate
' **输 入:无
' **输 出:无
' **功能描述:
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 16:36:21
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Private Sub Class_Terminate()
Call ClosePort
End Sub
' **模 块 名:SerialPort
' **说 明:YFsoft 版权所有2006 - 2007(C)
' **创 建 人:叶帆
' **日 期:2006-08-17 14:32:29
' **修 改 人:
' **日 期:
' **描 述:串口异步读写(API)
' **版 本:V1.0.0
' *************************************************************************
Option Explicit
Private 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
Private Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type
Private Type DCB
DCBlength As Long
BaudRate As Long
' DWORD DCBlength; /* sizeof(DCB) */
' DWORD BaudRate; /* Baudrate at which running */
' DWORD fBinary: 1; /* Binary Mode (skip EOF check) */
' DWORD fParity: 1; /* Enable parity checking */
' DWORD fOutxCtsFlow:1; /* CTS handshaking on output */
' DWORD fOutxDsrFlow:1; /* DSR handshaking on output */
' DWORD fDtrControl:2; /* DTR Flow control */
' DWORD fDsrSensitivity:1; /* DSR Sensitivity */
' DWORD fTXContinueOnXoff: 1; /* Continue TX when Xoff sent */
' DWORD fOutX: 1; /* Enable output X-ON/X-OFF */
' DWORD fInX: 1; /* Enable input X-ON/X-OFF */
' DWORD fErrorChar: 1; /* Enable Err Replacement */
' DWORD fNull: 1; /* Enable Null stripping */
' DWORD fRtsControl:2; /* Rts Flow control */
' DWORD fAbortOnError:1; /* Abort all reads and writes on Error */
' DWORD fDummy2:17; /* Reserved */
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 OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CloseHandle Lib " kernel32 " ( ByVal hObject As Long ) As Long
Private Declare Function GetLastError Lib " kernel32 " () As Long
Private Declare Function ReadFile Lib " kernel32 " ( ByVal hFile As Long , lpBuffer As Any, ByVal nNumberOfBytesToRead As Long , lpNumberOfBytesRead As Long , lpOverlapped As OVERLAPPED) As Long
Private Declare Function WriteFile Lib " kernel32 " ( ByVal hFile As Long , lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long , lpNumberOfBytesWritten As Long , lpOverlapped As OVERLAPPED) As Long ' OVERLAPPED
Private Declare Function SetCommTimeouts Lib " kernel32 " ( ByVal hFile As Long , lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function GetCommTimeouts Lib " kernel32 " ( ByVal hFile As Long , lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function BuildCommDCB Lib " kernel32 " Alias " BuildCommDCBA " ( ByVal lpDef As String , lpDCB As DCB) As Long
Private Declare Function SetCommState Lib " kernel32 " ( ByVal hCommDev As Long , lpDCB As DCB) As Long
Private Declare Function GetCommState Lib " kernel32 " ( ByVal nCid As Long , lpDCB As DCB) As Long
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 FlushFileBuffers Lib " kernel32 " ( ByVal hFile As Long ) As Long
Private Declare Function CreateEvent Lib " kernel32 " Alias " CreateEventA " (lpEventAttributes As SECURITY_ATTRIBUTES, ByVal bManualReset As Long , ByVal bInitialState As Long , ByVal lpName As String ) As Long
Private Declare Function SetCommMask Lib " kernel32 " ( ByVal hFile As Long , ByVal dwEvtMask As Long ) As Long
Private Declare Function SetEvent Lib " kernel32 " ( ByVal hEvent As Long ) As Long
Private Declare Function PurgeComm Lib " kernel32 " ( ByVal hFile As Long , ByVal dwFlags As Long ) As Long
Private Declare Function ClearCommError Lib " kernel32 " ( ByVal hFile As Long , lpErrors As Long , lpStat As ComStat) As Long
Private Declare Function GetOverlappedResult Lib " kernel32 " ( ByVal hFile As Long , lpOverlapped As OVERLAPPED, lpNumberOfBytesTransferred As Long , ByVal bWait As Long ) As Long
Private Declare Function WaitForSingleObject Lib " kernel32 " ( ByVal hHandle As Long , ByVal dwMilliseconds As Long ) As Long
Private Declare Function SetupComm Lib " kernel32 " ( ByVal hFile As Long , ByVal dwInQueue As Long , ByVal dwOutQueue As Long ) As Long
Private Const GENERIC_WRITE = & H40000000
Private Const GENERIC_READ = & H80000000
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = & H80
Private Const FILE_FLAG_OVERLAPPED = & H40000000
Private Const DTR_CONTROL_DISABLE = & H0
Private Const RTS_CONTROL_ENABLE = & H1
Private Const PURGE_RXABORT = & H2
Private Const PURGE_RXCLEAR = & H8
Private Const PURGE_TXABORT = & H1
Private Const PURGE_TXCLEAR = & H4
Private Const ERROR_IO_PENDING = 997
Private Const STATUS_WAIT_0 = & H0
Private Const WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0 )
Private Const WAIT_TIMEOUT = 258 &
Private m_Handle As Long
Private m_OverlappedRead As OVERLAPPED
Private m_OverlappedWrite As OVERLAPPED
' *************************************************************************
' **函 数 名:OpenPort
' **输 入:ComNumber(Long) - 串口号
' ** :Comsettings(String) - 配置信息
' **输 出:(Long) - 0 成功 非 0 失败
' **功能描述:打开串口
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:40:14
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function OpenPort(ComNumber As Long , Comsettings As String , Optional lngInSize As Long = 1024 , Optional lngOutSize As Long = 512 ) As Long
On Error GoTo handelinitcom
Dim retval As Long
Dim CtimeOut As COMMTIMEOUTS, dcbs As DCB
Dim strCOM As String , strConfig As String
strCOM = " /.COM " & Format (ComNumber, " 0 " )
m_Handle = CreateFile(strCOM, GENERIC_READ Or GENERIC_WRITE, 0 , 0 & , OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0 )
If m_Handle = - 1 Then
OpenPort = - 1
Exit Function
End If
' 设置dcb块
dcbs.DCBlength = Len (dcbs) ' 长度
Call GetCommState(m_Handle, dcbs)
' 波特率,奇偶校验,数据位,停止位 如:9600,n,8,1
strConfig = " COM " & Format (ComNumber, " 0 " ) & " : " & Comsettings
Call BuildCommDCB(strConfig, dcbs)
' ------------------------------
' dcbs.fBinary = 1 '二进制方式
' dcbs.fOutxCtsFlow = 0 '不用CTS检测发送流控制
' dcbs.fOutxDsrFlow = 0 '不用DSR检测发送流控制
' dcbs.fDtrControl = DTR_CONTROL_DISABLE '禁止DTR流量控制
' dcbs.fDsrSensitivity = 0 '对DTR信号线不敏感
' dcbs.fTXContinueOnXoff = 1 '检测接收缓冲区
' dcbs.fOutX = 0 '不做发送字符控制
' dcbs.fInX = 0 '不做接收控制
' dcbs.fErrorChar = 0 '是否用指定字符替换校验错的字符
' dcbs.fNull = 0 '保留NULL字符
' dcbs.fRtsControl = RTS_CONTROL_ENABLE '允许RTS流量控制
' dcbs.fAbortOnError = 0 '发送错误后,继续进行下面的读写操作
' dcbs.fDummy2 = 0 '保留
dcbs.fBitFields = 1 * 2 ^ 0 Or DTR_CONTROL_DISABLE * 2 ^ 4 Or 1 * 2 ^ 7 Or RTS_CONTROL_ENABLE * 2 ^ 12
dcbs.wReserved = 0 ' 没有使用,必须为0
dcbs.XonLim = 0 ' 指定在XOFF字符发送之前接收到缓冲区中可允许的最小字节数
dcbs.XoffLim = 0 ' 指定在XOFF字符发送之前缓冲区中可允许的最小可用字节数
dcbs.XonChar = 0 ' 发送和接收的XON字符
dcbs.XoffChar = 0 ' 发送和接收的XOFF字符
dcbs.ErrorChar = 0 ' 代替接收到奇偶校验错误的字符
dcbs.EofChar = 0 ' 用来表示数据的结束
dcbs.EvtChar = 0 ' 事件字符,接收到此字符时,会产生一个事件
' dcbs.wReserved1 = 0 '没有使用
' dcbs.BaudRate =9600 '波特率
' dcbs.Parity=0 '奇偶校验
' dcbs.ByteSize=8 '数据位
' dcbs.StopBits=0 '停止位
' ------------------------------
If dcbs.Parity = 0 Then ' 0-4=None,Odd,Even,Mark,Space
dcbs.fBitFields = dcbs.fBitFields And & HFFFD ' dcbs.fParity = 0 '奇偶校验无效
Else
dcbs.fBitFields = dcbs.fBitFields Or & H2 ' dcbs.fParity = 1 '奇偶校验有效
End If
' 超时设置
CtimeOut.ReadIntervalTimeout = 20 ' 0
CtimeOut.ReadTotalTimeoutConstant = 1 ' 2500
CtimeOut.ReadTotalTimeoutMultiplier = 1 ' 0
CtimeOut.WriteTotalTimeoutConstant = 10 ' 2500
CtimeOut.WriteTotalTimeoutMultiplier = 1 ' 0
retval = SetCommTimeouts(m_Handle, CtimeOut)
If retval = - 1 Then
retval = GetLastError()
OpenPort = retval
retval = CloseHandle(m_Handle)
Exit Function
End If
' 获取信号句柄
Dim lpEventAttributes1 As SECURITY_ATTRIBUTES
Dim lpEventAttributes2 As SECURITY_ATTRIBUTES
m_OverlappedRead.hEvent = CreateEvent(lpEventAttributes1, 1 , 0 , 0 )
m_OverlappedWrite.hEvent = CreateEvent(lpEventAttributes2, 1 , 0 , 0 )
' 判断设置参数是否成功 设置输入和输出缓冲区是否成功
If SetCommState(m_Handle, dcbs) = - 1 Or SetupComm(m_Handle, lngInSize, lngOutSize) = - 1 Or m_OverlappedRead.hEvent = 0 Or m_OverlappedWrite.hEvent = 0 Then
retval = GetLastError()
OpenPort = retval
If (m_OverlappedRead.hEvent <> 0 ) Then CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0 ) Then CloseHandle (m_OverlappedWrite.hEvent)
Call CloseHandle(m_Handle)
m_Handle = 0
Exit Function
End If
OpenPort = 0
Exit Function
handelinitcom:
Call CloseHandle(m_Handle)
m_Handle = 0
OpenPort = - 2
Exit Function
End Function
' *************************************************************************
' **函 数 名:ClosePort
' **输 入:无
' **输 出:(Long) - 0 成功 -1 失败
' **功能描述:关闭串口
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:56:13
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClosePort() As Long
If (m_Handle = 0 ) Then
ClosePort = 1
Exit Function
End If
Call SetCommMask(m_Handle, 0 )
Call SetEvent(m_OverlappedRead.hEvent)
Call SetEvent(m_OverlappedWrite.hEvent)
If (m_OverlappedRead.hEvent <> 0 ) Then CloseHandle (m_OverlappedRead.hEvent)
If (m_OverlappedWrite.hEvent <> 0 ) Then CloseHandle (m_OverlappedWrite.hEvent)
If CloseHandle(m_Handle) <> 0 Then
ClosePort = 0
Else
ClosePort = - 1
End If
m_Handle = 0
End Function
' *************************************************************************
' **函 数 名:ClearInBuf
' **输 入:无
' **输 出:无
' **功能描述:清空输入缓冲区
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 14:57:26
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClearInBuf() As Long
If (m_Handle = 0 ) Then
ClearInBuf = 1
Exit Function
End If
Call PurgeComm(m_Handle, PURGE_RXABORT Or PURGE_RXCLEAR)
ClearInBuf = 0
End Function
' *************************************************************************
' **函 数 名:ClearOutBuf
' **输 入:无
' **输 出:(Long) -
' **功能描述:清空输出缓冲区
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 15:40:38
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ClearOutBuf() As Long
If (m_Handle = 0 ) Then
ClearOutBuf = 1
Exit Function
End If
Call PurgeComm(m_Handle, PURGE_TXABORT Or PURGE_TXCLEAR)
ClearOutBuf = 0
End Function
' *************************************************************************
' **函 数 名:SendData
' **输 入:bytBuffer()(Byte) - 数据
' ** :lngSize(Long) - 数据长度
' **输 出:(Long) -
' **功能描述:发送数据
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 15:43:42
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function SendData(bytBuffer() As Byte , lngSize As Long ) As Long
On Error GoTo ToExit ' 打开错误陷阱
' ------------------------------------------------
If (m_Handle = 0 ) Then
SendData = 1
Exit Function
End If
Dim dwBytesWritten As Long
Dim bWriteStat As Long
Dim ComStats As ComStat
Dim dwErrorFlags As Long
dwBytesWritten = lngSize
Call ClearCommError(m_Handle, dwErrorFlags, ComStats)
bWriteStat = WriteFile(m_Handle, bytBuffer( 0 ), lngSize, dwBytesWritten, m_OverlappedWrite)
If bWriteStat = 0 Then
If GetLastError() = ERROR_IO_PENDING Then
Call GetOverlappedResult(m_Handle, m_OverlappedWrite, dwBytesWritten, 1 ) ' 等待直到发送完毕
End If
Else
dwBytesWritten = 0
End If
SendData = dwBytesWritten
' ------------------------------------------------
Exit Function
' ----------------
ToExit:
SendData = - 1
End Function
' *************************************************************************
' **函 数 名:ReadData
' **输 入:bytBuffer()(Byte) - 数据
' ** :lngSize(Long) - 数据长度
' **输 出:(Long) -
' **功能描述:读取数据
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 16:04:38
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Public Function ReadData(bytBuffer() As Byte , lngSize As Long , Optional Overtime As Long = 3000 ) As Long
On Error GoTo ToExit ' 打开错误陷阱
' ------------------------------------------------
If (m_Handle = 0 ) Then
ReadData = 1
Exit Function
End If
Dim lngBytesRead As Long
Dim fReadStat As Long
Dim dwRes As Long
lngBytesRead = lngSize
' 读数据
fReadStat = ReadFile(m_Handle, bytBuffer( 0 ), lngSize, lngBytesRead, m_OverlappedRead)
If fReadStat = 0 Then
If GetLastError() = ERROR_IO_PENDING Then ' 重叠 I/O 操作在进行中
dwRes = WaitForSingleObject(m_OverlappedRead.hEvent, Overtime) ' 等待,直到超时
Select Case dwRes
Case WAIT_OBJECT_0: ' 读完成
If GetOverlappedResult(m_Handle, m_OverlappedRead, lngBytesRead, 0 ) = 0 Then
' 错误
ReadData = - 2
Exit Function
End If
Case WAIT_TIMEOUT: ' 超时
ReadData = - 1
Exit Function
Case Else : ' WaitForSingleObject 错误
End Select
End If
End If
ReadData = lngBytesRead
' ------------------------------------------------
Exit Function
' ----------------
ToExit:
ReadData = - 1
End Function
' *************************************************************************
' **函 数 名:Class_Terminate
' **输 入:无
' **输 出:无
' **功能描述:
' **全局变量:
' **调用模块:
' **作 者:叶帆
' **日 期:2006-08-17 16:36:21
' **修 改 人:
' **日 期:
' **版 本:V1.0.0
' *************************************************************************
Private Sub Class_Terminate()
Call ClosePort
End Sub