VB6使用API实现串口通信

    需要和客户的产品通讯，但波特率是非常规的，MScomm无法实现，原有的软件框架和条件又不能转用VC开发底层，于是用VB6调用API实现了这个通讯功能，虽然在VB6下这个程序还是单进程的，但实现了异步非阻塞的通信，性能相当稳定，下面是测试程序代码

 

Private Sub cmdSend_Click()Sub cmdSend_Click()
    '定义文件读写属性结构
    Dim sa As SECURITY_ATTRIBUTES
    '定义串口状态结构
    Dim typCommStat As COMSTAT
    '定义串口状态错误
    Dim lngError As Long
    
    '********打开串口********
    Dim hCF As Long
    hCF = CreateFile("COM4", _
                        GENERIC_READ Or GENERIC_WRITE, 0, sa, _
                    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
    Debug.Print "打开串口：" & hCF
    
    '********获取出错信息********
    Dim errNum As Long
    errNum = GetLastError()
    Debug.Print "出错信息：" & errNum
    
    '定义标志值
    Dim flag As Long
            
    '定义设备控制块
    Dim typDCB As DCB
    
    '********获取设备控制块********
    flag = GetCommState(hCF, typDCB)
    Debug.Print "获取串口DCB：" & flag
    
    typDCB.BaudRate = 2500     '定义波特率
    typDCB.Parity = NOPARITY   '无校验位
    typDCB.ByteSize = 8        '数据位
    typDCB.StopBits = 0        '停止位 0/1/2 = 1/1.5/2
        
    '********设置串口参数********
    flag = SetCommState(hCF, typDCB)
    Debug.Print "设置串口参数：" & flag
    
    '********设置缓冲区大小********
    flag = SetupComm(hCF, 1024, 1024)
    'Debug.Print "设置缓冲区：" & flag
    
    '********清空读写缓冲区********
    flag = PurgeComm(hCF, PURGE_RXABORT Or PURGE_RXCLEAR Or PURGE_TXABORT Or PURGE_TXCLEAR)
    'Debug.Print "强制清空缓冲区：" & flag
    
    '定义超时结构体
    Dim typCommTimeouts As COMMTIMEOUTS
    typCommTimeouts.ReadIntervalTimeout = 0     '相邻两字节读取最大时间间隔（为0表示不使用该超时间隔）
    typCommTimeouts.ReadTotalTimeoutMultiplier = 0      '一个读操作的时间常数
    typCommTimeouts.ReadTotalTimeoutConstant = 0        '读超时常数
    typCommTimeouts.WriteTotalTimeoutMultiplier = 0     '一个写操作的时间常数（为0表示不使用该超时间隔）
    typCommTimeouts.WriteTotalTimeoutConstant = 0       '写超时常数（为0表示不使用该超时间隔）
        
    '********超时设置********
    flag = SetCommTimeouts(hCF, typCommTimeouts)
    'Debug.Print "超时设置：" & flag
        
    '********发送数据********
    '定义要发送字节数
    Dim lngNumberofBytesToWrite As Long
    '定义实际发送字节数
    Dim lngNumberofBytesToWritten As Long
    '定义重叠结构体
    Dim typOverLapped As OVERLAPPED
    
    '定义发送数据
    Dim arrbytTest(0 To 23) As Byte
    '载波收发器同步头
    arrbytTest(0) = CByte(&H53)
    arrbytTest(1) = CByte(&H4E)
    arrbytTest(2) = CByte(&H44)
    '后续数据包长度
    arrbytTest(3) = CByte(&H14)
    '载波表预同步头
    arrbytTest(4) = CByte(&HFF)
    arrbytTest(5) = CByte(&HFF)
    arrbytTest(6) = CByte(&HFF)
    arrbytTest(7) = CByte(&HFF)
    arrbytTest(8) = CByte(&HFF)
    arrbytTest(9) = CByte(&HFF)
    '载波表帧同步头
    arrbytTest(10) = CByte(&H9)
    arrbytTest(11) = CByte(&HAF)
    '载波表地址
    arrbytTest(12) = CByte(&H59)
    arrbytTest(13) = CByte(&H20)
    arrbytTest(14) = CByte(&H0)
    '控制码
    arrbytTest(15) = CByte(&H1)
    '数据长度
    arrbytTest(16) = CByte(&H5)
    '功能码
    arrbytTest(17) = CByte(&H10)
    arrbytTest(18) = CByte(&H90)
    '集中器地址
    arrbytTest(19) = CByte(&HBB)
    arrbytTest(20) = CByte(&HBB)
    arrbytTest(21) = CByte(&HBB)
    '校验和
    arrbytTest(22) = CByte(&H50)
    arrbytTest(23) = CByte(&H3)

        
    '获取要发送字节数
    lngNumberofBytesToWrite = UBound(arrbytTest) + 1
    
    '声明等待开始时间、结束时间值
    Dim writeStarTime, writeEndTime As Long
    
    writeStarTime = GetTickCount()
    Debug.Print "发送开始时间：" & writeStarTime
    
    '定义发送循环步长值
    Dim i As Integer
    '定义累计发送字节数
    Dim intTotalNumberOfBytesToWritten As Integer
    '定义发送间隔时间（毫秒）
    Dim intIntervalTime As Integer
    intIntervalTime = 0
    
    '发送数据
    For i = 0 To UBound(arrbytTest)
        flag = WriteFile(hCF, arrbytTest(i), 1, lngNumberofBytesToWritten, typOverLapped)
        
        '获取出错码
        errNum = GetLastError()
        'Debug.Print "发送操作出错码：" & errNum

        '若返回值不是IO异步操作未决，则关闭串口
        If (errNum <> ERROR_IO_PENDING) And (errNum <> 0) Then GoTo closeComm

        '异步IO事件获取（返回值为 0 表示出错）
        flag = WaitForSingleObject(typOverLapped.hEvent, 0)
        'Debug.Print "异步IO事件获取：" & flag

        '判断异步IO事件获取是否成功
        If flag <> 0 Then
            '异步IO操作结果获取(等待标记值，必须为true ，否则需要事件激活返回结果)
            flag = GetOverlappedResult(hCF, typOverLapped, lngNumberofBytesToWritten, 1)
            'Debug.Print "异步IO操作获取：" & flag

            '判断异步IO操作结果获取是否成功
            If flag <> 0 Then
                intTotalNumberOfBytesToWritten = intTotalNumberOfBytesToWritten + _
                                                    lngNumberofBytesToWritten
            End If

        End If
        
        '间隔时间（用于需要设定每字节间间隔时间的发送协议）
        Sleep (intIntervalTime)
    Next
    
    writeEndTime = GetTickCount()
    Debug.Print "发送结束时间：" & writeEndTime
    Debug.Print "发送总时间：" & (writeEndTime - writeStarTime)
    Debug.Print "串口发送操作：" & flag
    Debug.Print "实际发送字节数：" & intTotalNumberOfBytesToWritten
        
    '********清空缓冲区等待数据接收********
    flag = FlushFileBuffers(hCF)
    'Debug.Print "清空缓冲区：" & flag
    
    '********设置串口事件********
    '监听数据接收事件
'    flag = SetCommMask(hCF, EV_ERR Or EV_RXCHAR)
'    Debug.Print "监听事件设置：" & flag
    flag = SetCommMask(hCF, 0)
    Debug.Print "监听事件设置：" & flag
    
    '********等待串口接收事件********
    '声明等待开始时间、结束时间值
    Dim sngStarTime, sngEndTime As Long
    '事件掩码
    Dim lngEventMask As Long
    
    '定义接收字节数变量
    Dim tempReceive As Long
    tempReceive = 0
        
    Debug.Print "监听开始"
    '生成开始时间
    sngStarTime = GetTickCount()
    Debug.Print "开始监听时间：" & sngStarTime
    
    '定义等待步骤参数
    Dim n As Integer
    n = 1
    
'    '监听串口事件
'    flag = WaitCommEvent(hCF, lngEventMask, typOverLapped)
'    Debug.Print "监听操作：" & flag

'    '获取出错码
'    errNum = GetLastError()
'    Debug.Print "监听操作出错码：" & errNum
'
'    '若返回值不是IO异步操作未决，则关闭串口
'    If (errNum <> ERROR_IO_PENDING) And (errNum <> 0) Then GoTo closeComm

    '定义读取间隔时间(毫秒)
    Dim intReadIntervalTime As Integer
    intReadIntervalTime = 1
    
    Do
        
'        '异步IO事件获取（返回值为 0 表示出错）
'        flag = WaitForSingleObject(typOverLapped.hEvent, 0)
'        Debug.Print "异步IO事件获取：" & flag
'        '获取出错码
'        errNum = GetLastError()
'        Debug.Print "IO事件获取出错码：" & errNum
                      
        '清除错误标志函数，获取串口设备状态
        flag = ClearCommError(hCF, lngError, typCommStat)
        Debug.Print "获取串口设备状态：" & flag

        '若获取状态成功
        If (flag <> 0) And (typCommStat.cbInQue > 0) Then

            Debug.Print "已接收字节数：" & typCommStat.cbInQue

            '判断接收缓冲区内的数据是否等于需要接收的字节数
            If typCommStat.cbInQue >= 22 Then
                '跳出循环
                Debug.Print "跳出循环"
                Exit Do
            End If

        End If
        
        '生成结束时间
        sngEndTime = GetTickCount()
        Debug.Print "第" & n & "次监听事件时间：" & sngEndTime
        
        n = n + 1
                
        '读时间间隔
        Sleep (intReadIntervalTime)
        
    Loop Until (sngEndTime - sngStarTime) > 1000
    
    '生成结束时间
    sngEndTime = GetTickCount()
    Debug.Print "结束监听时间：" & sngEndTime
    
    Debug.Print "监听结束"
    Debug.Print "总接收时间：" & (sngEndTime - sngStarTime)
        
    '********接收数据********
    '定义接收数组
    Dim arrbytReceive(0 To 22) As Byte
    '定义实际接收字节数
    Dim lngNBR As Long
    '重叠结构置0
    typOverLapped.hEvent = 0
    typOverLapped.Internal = 0
    typOverLapped.InternalHigh = 0
    typOverLapped.offset = 0
    typOverLapped.OffsetHigh = 0
    
    '接收数据
    flag = ReadFile(hCF, arrbytReceive(0), 23, lngNBR, typOverLapped)
    Debug.Print "串口接收操作：" & flag
    Debug.Print "实际接收字节数：" & lngNBR
    Debug.Print arrbytReceive(0)
    Debug.Print arrbytReceive(21)
    Debug.Print arrbytReceive(22)

closeComm:
    '********关闭所有串口事件********
    flag = SetCommMask(hCF, 0)
    'Debug.Print "关闭串口事件：" & flag
    
    '********关闭串口********
    Dim closeFlag As Long
    closeFlag = CloseHandle(hCF)
    Debug.Print "关闭串口：" & closeFlag

End Sub