用API實作序列槽異步讀寫

VB的MSCOMM控件雖然很好用，但是在沒有裝VB的機器上用該控件總覺得有些累贅，網上的VB API代碼大部分都基于是同步方式，處理複雜的通信模式不是太理想，是以用了一些時間，把VC項目中的異步序列槽讀寫代碼翻譯為VB格式。

在VB建立一個類，把下面的代碼複制後即可使用

'*************************************************************************

'**模塊名：SerialPort

'**創建人：葉帆

'**日期：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

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

Private Type OVERLAPPED

Internal As Long

InternalHigh As Long

offset As Long

OffsetHigh As Long

hEvent As Long

Private Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDescriptor As Long

bInheritHandle As Long

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

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 '奇偶校驗有效

'逾時設定

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)

'擷取信号句柄

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

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

OpenPort = 0

Exit Function

handelinitcom:

Call CloseHandle(m_Handle)

m_Handle = 0

OpenPort = -2

End Function

'**函數名：ClosePort

'**輸入：無

'**輸出：(Long) - 0 成功 -1 失敗

'**功能描述：關閉序列槽

'**日期：2006-08-17 14:56:13

Public Function ClosePort() As Long

If (m_Handle = 0) Then

ClosePort = 1

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

ClosePort = -1

'**函數名：ClearInBuf

'**輸出：無

'**功能描述：清空輸入緩沖區

'**日期：2006-08-17 14:57:26

Public Function ClearInBuf() As Long

ClearInBuf = 1

Call PurgeComm(m_Handle, PURGE_RXABORT Or PURGE_RXCLEAR)

ClearInBuf = 0

'**函數名：ClearOutBuf

'**輸出：(Long) -

'**功能描述：清空輸出緩沖區

'**日期：2006-08-17 15:40:38

Public Function ClearOutBuf() As Long

ClearOutBuf = 1

Call PurgeComm(m_Handle, PURGE_TXABORT Or PURGE_TXCLEAR)

ClearOutBuf = 0

'**函數名：SendData

'**輸入：bytBuffer()(Byte) - 資料

'** ：lngSize(Long) - 資料長度

'**功能描述：發送資料

'**日期：2006-08-17 15:43:42

Public Function SendData(bytBuffer() As Byte, lngSize As Long) As Long

On Error GoTo ToExit '打開錯誤陷阱

'------------------------------------------------

SendData = 1

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

dwBytesWritten = 0

SendData = dwBytesWritten

'----------------

ToExit:

SendData = -1

'**函數名：ReadData

'**功能描述：讀取資料

'**日期：2006-08-17 16:04:38

Public Function ReadData(bytBuffer() As Byte, lngSize As Long, Optional Overtime As Long = 3000) As Long

ReadData = 1

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

ReadData = lngBytesRead

ReadData = -1

'**函數名：Class_Terminate

'**功能描述：

'**日期：2006-08-17 16:36:21

Private Sub Class_Terminate()

Call ClosePort

End Sub

用API實作序列槽異步讀寫

繼續閱讀

在Windows Mobile 6上通過CEMAPI POOM發送短信

.NET CF C# 位圖的任意角度旋轉

在核心模式驅動程式中調用 DLL

ASSERT與VERIFY宏的差別

WebBrowser獨立IE使用代理

java基礎知識問答集

Havok Physics 翻譯資料（1）Chapter 1.介紹

Facebook官方文檔學習 - 調用接口篇

用Windows Live Writer寫CSDN博

[轉] 擷取實時股票資料與股票資料接口API

RFC SDK 指南用戶端程式的編寫

Java8新的時間API擷取時間內插補點Java8新的時間API擷取時間內插補點與以前的java.util.Date擷取時間內插補點對比

手機軟體抓包工具及其使用方法

推薦一些VB的學習交流網站

GNU科學函數庫[參考手冊][v0.1 Build 090129 Beta][GNU Scientific Library]

與專家面對面：Android開發入門問與答