在VB中利用API进行串口通信

在VB中利用API进行串口通信

一般来说，在VB中编写串口通讯程序，首先考虑到是使用MSComm控件，可是该控件不能设置超时，而且对许多内部的参数进行了隐藏，从而不能满足有些具体的工作。而使用API进行串口通信，大多是使用VC，很少见到完整的VB代码，为此，我编写了这个模块。

    同时，由于串口通信是基于字节流的，为方便程序设计，我还编写了三个简单的辅助函数，并写了一个详细的测试代码。

    如果读者有好的建议，欢迎留言告知。具体代码如下：

'* ******************************************************* *   
'*    程序名称：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 
'* ******************************************************* *
'*    程序名称：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

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/lyserver/archive/2009/05/06/4153335.aspx