VB6使用API实现串口通信

Question

需要和客户的产品通讯，但波特率是非常规的，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

Answer 1

'********发送数据********
    '定义要发送字节数
    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
    

Answer 2

'********设置串口事件********
    '监听数据接收事件
'    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 "关闭串口：" & closeFlagEnd Sub

Answer 3

Private Sub cmdSend_Click()Sub cmdSend_Click()
上行代码对吗？
API的声明在那？
正想学习，谢谢！

Answer 4

Private Sub cmdSend_Click()Sub cmdSend_Click() 这个是copy时多了Sub cmdSend_Click()，删了就行，所有结构体，常数、API声明都能在VB6自带的API浏览器找到，自己找找就行

Answer 5

调试出现
打开串口：-1
出错信息：0
获取串口DCB：0
设置串口参数：0
设置缓冲区：0
强制清空缓冲区：0
超时设置：0
发送开始时间：40050222
发送操作出错码：6
关闭串口事件：0
关闭串口：0且无数据发出，请指明原因，谢谢！

Answer 6

打开串口：-1
看看这个在程序哪里print出来的，看看什么函数操作，错误很明显，给点点耐心，单步调试就能找到

Answer 7

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("COM1", _
                        GENERIC_READ Or GENERIC_WRITE, 0, sa, _
                    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
    Debug.Print "打开串口：" & hCF '打开串口：-1
   
   '.........
   '........
End Sub    楼主jackylingzeng(咕噜咕噜):
    打开串口：-1
    看看这个在程序哪里print出来的，看看什么函数操作，错误很明显，给点点耐心，单步调试就能找到
    用什么函数操作当然非常清楚.
    错误很明显?不理解.
    耐心有,但需正确理解,希望楼主能指明,谢谢!

Answer 8

Private Sub cmdSend_Click()Sub cmdSend_Click()这里把它改回去把，我贴的时候贴多了，我这几天在家，新装了系统没有MSDN 看不到CreateFile返回－1是不是错了，不过我记得正确时是返回1的，如果你用串口调试工具能成功控制串口，这么说明串口是没有问题的，不过如果用一般串口调试工具检测串口，这样就会出现资源独占，这时你再用这个程序就不能取得串口资源，你需要找个使用虚拟设备技术的串口检测软件，我有不过放在公司，也忘了什么名字了，假期后告诉你

Answer 9

用AccessPort 1.33 这个吧，它的串口监听不会占用串口资源，不过一定要先打开它，然后再使用程序获取资源

Answer 10

楼主,我的机器有COM1和COM2两个串口,我用串口调试精灵打开COM2,用你的代码打开COM1,执行COMSEND按钮事件,串口调试精灵侧未收到任何数据.
同样串口调试精灵打开COM1,用你的代码打开COM1执行COMSEND按钮事件也未见串口冲突发生.
故不得要领,望帮助.

Answer 11

首先，你用COM1发COM2收，使用什么串口线，如果事普通市面上买的通讯线，那应该是平行线，因为串口是2、3发送接受的，所以你要串口连串口，就要让2、3交叉，这个和网线的平行线、交叉线的原理一样。
  第二，串口调试精灵打开串口后，肯定会独占资源，所以我VB程序，无法取得串口，CreateFile只会返回-1，建议你先用VB调用MSComm控件，把通讯整体了解后，测通了，再测试我的程序。
  使用AccessPort 这个工具来监视串口，不要用它打开串口，只是使用它的监视功能，它使用虚拟设备技术，不会占用串口资源就能看到串口的数据收发

Answer 12

楼主:两个串口的通讯线是做的,无任何问题.串口调试精灵使用COM2口,另用MSComm控件使用COM1口,进行调试无任何问题.
之所以对你的代码感兴趣,就是想能深入了解WINAPI在串口的应用.第二，串口调试精灵打开串口后，肯定会独占资源
关于第二:是否你的代码在有MSComm控件使用一个COM口后(例如COM1口)会独占所有COM资源,再使用VB通过API声明使用COM2口也会无法实现?

Answer 13

一个程序打开一个串口后，只会独占一个串口资源
我的程序使用2500的bps，你是否把两个串口都调成相同的波特率，改成常规BPS试试吧

Answer 14

CreateFile("COM1", GENERIC_READ Or GENERIC_WRITE, 0, 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0&)
COM1后面没有空格