VB串行通信

Question

高手可以看下我的程序为什么不能收发数据么？那个com_h总反回-1是为什么？
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 Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Private Type CREATE_PROCESS_DEBUG_INFO
        hFile As Long
        hProcess As Long
        hThread As Long
        lpBaseOfImage As Long
        dwDebugInfoFileOffset As Long
        nDebugInfoSize As Long
        lpThreadLocalBase As Long
        lpStartAddress As Long
        lpImageName As Long
        fUnicode As Integer
End Type
Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End TypePrivate Sub Command1_Click()
com1_h = CreateFile("com1", (GENERIC_READ Or GENERIC_WRITE), 0, ByVal 0&, OPEN_EXISTING, 0, 0)  '打开COM1串行，把其句柄传给变量COM1_H
Print com1_h
End Sub
Private Sub Command2_Click()
    Dim t1 As Long
    Text1.Text = String(1, "1")
'    t1 = 1
    WriteFile com1_h, Asc(Text1.Text), Len(Text1.Text), t1, 0
    'Text1.Text = dcb0.BaudRate
    'Timer2.Enabled = True
End Sub
Private Sub Command3_Click()
    Dim t1 As Long
    Text2.Text = String(1, "2")
'    t1 = 1
    ReadFile com1_h, Asc(Text2.Text), Len(Text2.Text), t1, 0    'Text1.Text = dcb0.BaudRate
    'Timer2.Enabled = True
End Sub

Answer 1

给段能用的API串口通信代码：
Option Explicit
    Private ComNum As Long
    Private bRead(255) As Byte
    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
        fBinary As Long
        fParity As Long
        fOutxCtsFlow As Long
        fOutxDsrFlow As Long
        fDtrControl As Long
        fDsrSensitivity As Long
        fTXContinueOnXoff As Long
        fOutX As Long
        fInX As Long
        fErrorChar As Long
        fNull As Long
        fRtsControl As Long
        fAbortOnError As Long
        fDummy2 As Long
        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
    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 sa As SECURITY_ATTRIBUTES
    'Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) 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 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 Long) As Long
    Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
    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 FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
    Private strData1 As String
    Private strData As String
    Private intOutMode As Byte
End Sub

Answer 2

Function fin_com()
    fin_com = CloseHandle(ComNum)
End Function'关闭端口
Function FlushComm()
    FlushFileBuffers (ComNum)
End Function'初始化端口
Function Init_Com(ComNumber As String, Comsettings As String) As Boolean
On Error GoTo handelinitcom
    Dim ComSetup As DCB, Answer, Stat As COMSTAT, RetBytes As Long
    Dim retval As Long
    Dim CtimeOut As COMMTIMEOUTS, BarDCB As DCB
    ' 打开通讯口读/写(&HC0000000).
    ' 必须指定存在的文件 (3).
    'ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
    ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
    Print ComNum
    If ComNum = -1 Then
        frmSerialTs.Shape1.FillColor = vbRed
        MsgBox "端口 " & ComNumber & "无效. 请设置正确.", 48
        Init_Com = False
        Exit Function
    ElseIf ComNum <> -1 Then
        frmSerialTs.Shape1.FillColor = vbGreen
    End If
    '超时
    CtimeOut.ReadIntervalTimeout = 20
    CtimeOut.ReadTotalTimeoutConstant = 1
    CtimeOut.ReadTotalTimeoutMultiplier = 1
    CtimeOut.WriteTotalTimeoutConstant = 10
    CtimeOut.WriteTotalTimeoutMultiplier = 1
    retval = SetCommTimeouts(ComNum, CtimeOut)
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "端口超时设定无效 " & ComNumber & " 错误: " & retval
        retval = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    retval = BuildCommDCB(Comsettings, BarDCB)
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "无效设备 DCB 块 " & Comsettings & " 错误: " & retval
        retval = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    retval = SetCommState(ComNum, BarDCB)
    If retval = -1 Then
        retval = GetLastError()
        MsgBox "无效设备 DCB 块 " & Comsettings & " 错误: " & retval
        retval = CloseHandle(ComNum)
        Init_Com = False
        Exit Function
    End If
    
    Init_Com = True
handelinitcom:
    Exit Function
End Function'从串口读取数据
Function ReadCommPure() As String
On Error GoTo handelpurecom
    Dim RetBytes As Long, i As Integer, ReadStr As String, retval As Long
    Dim CheckTotal As Integer, CheckDigitLC As Integer
    retval = ReadFile(ComNum, bRead(0), 255, RetBytes, 0)
    ReadStr = ""
    If (RetBytes > 0) Then
        For i = 0 To RetBytes - 1
            ReadStr = ReadStr & Chr(bRead(i))
        Next i
       Else
        FlushComm
    End If
    ReadCommPure = ReadStr
handelpurecom:
    Exit Function
End Function'向串口写数据
Function WriteCOM32(COMString As String) As Integer
On Error GoTo handelwritelpt
    Dim RetBytes As Long, LenVal As Long
    Dim retval As Long
    
    If Len(COMString) > 255 Then
        WriteCOM32 Left$(COMString, 255)
        WriteCOM32 Right$(COMString, Len(COMString) - 255)
        Exit Function
    End If
    
    For LenVal = 0 To Len(COMString) - 1
        bRead(LenVal) = Asc(Mid$(COMString, LenVal + 1, 1))
    Next LenVal
'    bRead(LenVal) = 0
    retval = WriteFile(ComNum, bRead(0), Len(COMString), RetBytes, 0)
'    FlushComm
    WriteCOM32 = RetBytes
    
handelwritelpt:
    Exit Function
End Function
Private Sub BTNCloseCom_Click() '关闭串口
    TMRComm.Enabled = False
    Call fin_com
    SwitchTags
End SubPrivate Sub BTNOpenCom_Click() '打开串口
    If Not Init_Com(txt(0).Text, txt(1).Text) Then
        MsgBox txt(0).Text & " 无效!"
        Exit Sub
    End If
    SwitchTags
    TMRComm.Enabled = True
End SubPrivate Sub BTNSend_Click() '发送ASCII字符
    If WriteCOM32(txtSend) & vbCr <> Len(txtSend) Then
        MsgBox "写入错误"
        Exit Sub
    End If
    txtRec.Text = ""
    Pic.FillColor = &HFF0000
End SubPrivate Sub Command1_Click() '发送BYTE字节
    Dim bytDaTa() As Byte
    Dim i As Integer
    strData1 = txtSend
    For i = 1 To Len(strData1) Step 2
       strData = strData & Chr(Val("&H" & Mid(strData1, i, 2)))
    Next
    WriteCOM32 (strData)
    strData = ""
End SubPrivate Sub Form_Load()
    intOutMode = 0
    Me.cboHexAscii.Text = "按ASCII码"
    TMRComm.Interval = 100
    TMRComm.Enabled = False
End SubPrivate Sub Form_Unload(Cancel As Integer)
    BTNCloseCom_Click '退出时关闭串口
End SubPrivate Sub TMRComm_Timer()
    Dim Ans As String, i As Integer, RtnStr As String
    Ans = ReadCommPure()
    If Pic.FillColor = &HFFFFFF Then
        Pic.FillColor = vbGreen
       Else
        Pic.FillColor = &HFFFFFF
    End If
    If Ans = "" Then Exit Sub
    Pic.FillColor = &HFF
    For i = 1 To Len(Ans)
        RtnStr = RtnStr & Hex(Asc(Mid$(Ans, i, 1))) & " "
    Next
    RtnStr = RtnStr & vbCrLf & vbCrLf & CleanStr(Ans)
    txtRec.Text = RtnStr
    FlushComm
End SubFunction CleanStr(TextLine As String) As String
    Dim i As Integer, RtnStr As String
    RtnStr = ""
    For i = 1 To Len(TextLine)
        Select Case Asc(Mid$(TextLine, i, 1))
            Case &H5D
                RtnStr = RtnStr & "<ACK>"
            Case &H5B
                RtnStr = RtnStr & "<NAK>"
            Case Is >= &H30
                RtnStr = RtnStr & Mid$(TextLine, i, 1)
            Case 13
                RtnStr = RtnStr & "<CR>"
            Case 10
                RtnStr = RtnStr & "<LF>"
            Case Else
                RtnStr = RtnStr & "@"
        End Select
    Next i
    CleanStr = RtnStr
End FunctionSub SwitchTags()
    Dim xs As Control
    For Each xs In Me
        If xs.Tag <> "" Then
            xs.Enabled = Not xs.Enabled
        End If
    Next
End Sub
全部依据枕善居提供代码改写。

Answer 3

补充遗漏代码：
Private Sub cboHexAscii_Click()
    If Me.cboHexAscii.Text = "按ASCII码" Then
        intOutMode = 0
    Else
        intOutMode = 1
    End If
End Sub

Answer 4

LZ:你
Command1_Click事件中
    Com1_h = CreateFile("com1", (GENERIC_READ Or GENERIC_WRITE), 0, ByVal 0&, OPEN_EXISTING, 0, 0)  
GENERIC_READ
GENERIC_WRITE
OPEN_EXISTING
3常数未给赋值Option Explicit
    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 Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
    End Type
    Private Type CREATE_PROCESS_DEBUG_INFO
        hFile As Long
        hProcess As Long
        hThread As Long
        lpBaseOfImage As Long
        dwDebugInfoFileOffset As Long
        nDebugInfoSize As Long
        lpThreadLocalBase As Long
        lpStartAddress As Long
        lpImageName As Long
        fUnicode As Integer
    End Type
    Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
    End Type
    Private com1_h
    Const GENERIC_READ = &H80000000
    Const GENERIC_WRITE = &H40000000
    Const OPEN_EXISTING = 3
Private Sub Command1_Click()
    com1_h = CreateFile("com1", (GENERIC_READ Or GENERIC_WRITE), 0, ByVal 0&, OPEN_EXISTING, 0, 0)  '打开COM1串行，把其句柄传给变量COM1_H
    Print com1_h
End Sub

Answer 5

而且你需添加API
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
整个程序代码修改为：
Option Explicit
    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 Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
    End Type
    Private Type CREATE_PROCESS_DEBUG_INFO
        hFile As Long
        hProcess As Long
        hThread As Long
        lpBaseOfImage As Long
        dwDebugInfoFileOffset As Long
        nDebugInfoSize As Long
        lpThreadLocalBase As Long
        lpStartAddress As Long
        lpImageName As Long
        fUnicode As Integer
    End Type
    Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
    End Type
    Dim com1_h
    Const GENERIC_READ = &H80000000
    Const GENERIC_WRITE = &H40000000
    Const OPEN_EXISTING = 3
Private Sub Command1_Click()
    com1_h = CreateFile("com1", (GENERIC_READ Or GENERIC_WRITE), 0, ByVal 0&, OPEN_EXISTING, 0, 0)  '打开COM1串行，把其句柄传给变量COM1_H
    Print com1_h
End Sub
Private Sub Command2_Click()
    Dim t1 As Long
    Text1.Text = String(1, "1")
'    t1 = 1
    WriteFile com1_h, Asc(Text1.Text), Len(Text1.Text), t1, 0
    'Text1.Text = dcb0.BaudRate
    'Timer2.Enabled = True
End Sub
Private Sub Command3_Click()
    Dim t1 As Long
    Text2.Text = String(1, "2")
    ReadFile com1_h, Asc(Text2.Text), Len(Text2.Text), t1, 0
End SubPrivate Sub Command4_Click() '关闭COM口
    Call CloseHandle(com1_h)
End Sub
Function fin_com()
    fin_com = CloseHandle(ComNum)
End FunctionPrivate Sub Form_Load()
    Call CloseHandle(com1_h)
End Sub

Answer 6

非常感谢zdingyun 大虾！你真是位大好人！
那个你64楼帮我改的，我好像还不能用
能正常开关com1了！但还不能收发（text2始终显示2,不能显示1）,
我刚学API，还狠菜，想不通是为什么？

Answer 7

那么在我1楼到4楼的代码及界面你用过吗？
你那部分收发代码未查错。
你留个EMAIL地址
晚上到家给你发个完整的VB的API串口工程给你。

Answer 8

还没用那些，有好多要加的，懒。不过确实好啊，封装下可以做成MSCOMM_Ⅱ了哈哈。。对了，高手你知道怎么把你上面那段代码封装成控件DLL么（就像MSCOMM一样调用）？
偶E-MAIL：[email protected]
谢谢啦！

Answer 9

已将COMAPI的工程压缩文件发送到[email protected] 

Answer 10

给我也发一个吧，[email protected].大作业还没有昨晚，水深火热

Answer 11

可不可以发给我一个[email protected]...太感谢了。。

Answer 12

跪求……能不能也发给我一下，顺便问一下有没有多路串行实时控制的程序，也是用VB，毕业设计完全没有头绪的啊！谢谢！十分感谢！！！邮箱：[email protected]