vb实现波特率为10400的串口通讯

Sub SwitchTags()

    Dim xs As Control

    For Each xs In Me

        If xs.Tag <> "" Then

            xs.Enabled = Not xs.Enabled

        End If

    Next

End Sub

Private Sub OpenCom_Click()

    Call Init_Com("Com1:", "10400,n,8,1")

    SwitchTags

    Timer1.Enabled = True

    OpenCom.Enabled = False

    CloseCom.Enabled = True

End Sub



Private Sub _Click()

    Timer1.Enabled = False

    Call fin_com

    SwitchTags

    OpenCom.Enabled = True

    CloseCom.Enabled = False

End Sub

Option Explicit

Private Sub CloseCom_Click()

    Timer1.Enabled = False

    Call fin_com

    SwitchTags

End Sub



Private Sub cmdClare_Click()

    'RtnStr = ""

    txtRec.Text = ""

    strData = ""

    Text3 = ""

End Sub



Private Sub Form_Load()

    Text2 = ""

    Text3 = ""

    Timer1.Interval = 1

End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    CloseCom_Click '退出时关闭串口

End Sub



Private Sub OpenCom_Click()

    Call Init_Com("Com1:", "10400,n,8,1")

    SwitchTags

    Timer1.Enabled = True

End Sub



Sub SwitchTags()

    Dim xs As Control

    For Each xs In Me

        If xs.Tag <> "" Then

            xs.Enabled = Not xs.Enabled

        End If

    Next

End Sub



Private Sub Send_Click()

    If WriteCOM32(Text2) & vbCr <> Len(Text2) / 2 Then

        MsgBox "写入错误"

        Exit Sub

    End If

    txtRec.Text = ""

    Shape1.FillColor = &HFF0000

End Sub



Private Sub Timer1_Timer()

    Dim Ans As String

    Dim i As Integer

    Dim RtnStr As String

    Ans = ReadCommPure()

    If Shape1.FillColor = vbGreen Then ' &HFFFFFF

        Shape1.FillColor = vbRed '&H808080

    Else

        Shape1.FillColor = vbGreen '&HFFFFFF

    End If

    If Ans = "" Then Exit Sub

    Shape1.FillColor = &HFF

    Text3 = strData

    For i = 1 To Len(strData) Step 2

        If Val("&H" & Mid(strData, i, 2)) < 32 Or Val("&H" & Mid(strData, i, 2)) > 128 Then

        RtnStr = RtnStr & "."

        Else

        RtnStr = RtnStr & Chr(Val("&H" & Mid(strData, i, 2)))

        End If

    Next

    txtRec.Text = RtnStr

    RtnStr = CleanStr(Ans)

    FlushComm

End Sub



Function 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 Function

Option Explicit

    Public strData As String

    Global ComNum As Long

    Global bRead(255) As Byte

    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



    Type COMMTIMEOUTS

        ReadIntervalTimeout As Long

        ReadTotalTimeoutMultiplier As Long

        ReadTotalTimeoutConstant As Long

        WriteTotalTimeoutMultiplier As Long

        WriteTotalTimeoutConstant As Long

    End Type



    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



    Type OVERLAPPED

        Internal As Long

        InternalHigh As Long

        offset As Long

        OffsetHigh As Long

        hEvent As Long

    End Type

    

    Type SECURITY_ATTRIBUTES

        nLength As Long

        lpSecurityDescriptor As Long

        bInheritHandle As Long

    End Type

    Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

    Declare Function GetLastError Lib "kernel32" () As Long

    Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long

    Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Byte, lpOverlapped As Long) As Long

    Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long

    Declare Function GetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long

    Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String, lpDCB As DCB) As Long

    Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long

    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

    Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long



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)

    If ComNum = -1 Then

        frmCommApi.Shape1.FillColor = vbRed

        MsgBox "端口 " & ComNumber & "无效. 请设置正确.", 48

        Init_Com = False

        Exit Function

    ElseIf ComNum <> -1 Then

        frmCommApi.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)

    frmCommApi.Text1 = Comsettings

    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

    Dim i As Integer

    Dim ReadStr As String

    Dim retval As Long

    Dim CheckTotal As Integer

    Dim CheckDigitLC As Integer

    retval = ReadFile(ComNum, bRead(0), 255, RetBytes, 0)

    ReadStr = ""

    If (RetBytes > 0) Then

        For i = 0 To RetBytes - 1

            ReadStr = ReadStr & Hex(bRead(i))

            If Len(Hex(bRead(i))) = 1 Then

                strData = strData & "0" & Hex(bRead(i))  '转为16进制显示

            Else

                strData = strData & Hex(bRead(i))   '转为16进制显示

            End If

        Next i

       Else

        FlushComm

    End If

    ReadCommPure = ReadStr

handelpurecom:

    Exit Function

End Function



'向串口写数据Byte

Function WriteCOM32(COMString As String) As Integer

On Error GoTo handelwritelpt

    Dim strData As String

    Dim RetBytes As Byte, LenVal As Integer

    Dim retval As Byte

    For LenVal = 1 To Len(COMString) Step 2

        strData = Mid$(COMString, LenVal, 2)

        bRead((LenVal - 1) / 2) = Val("&H" & Mid$(COMString, LenVal, 2))

    Next LenVal

    retval = WriteFile(ComNum, bRead(0), Len(COMString) / 2, RetBytes, 0)

    WriteCOM32 = RetBytes

handelwritelpt:

    Exit Function

End Function

Private Sub Form_Load()

    MSComm1.Settings = "10472,n,8,1"

    MSComm1.PortOpen = True

End Sub