rs485.frm

详细介绍了使用VB编制串口通信程序

    For i = 1 To 8
        If i <> countt Then
            Shape1(i).BackColor = &HFF&             '&H000000FF&红色;&H0000FF00&绿色
        Else
            Shape1(countt).BackColor = &HFF00&
        End If
    Next
    Delay
    Read2000
'    MSComm2.PortOpen = False
End Sub

Private Sub Command2_Click()
    Status = 1
    runstop = Not (runstop)
    If (runstop) Then
        Command2.Caption = "连续暂停"
        Label18.Caption = "连续采集进行中…"
        Label18.ForeColor = &HFF00&
        Timer1.Enabled = True
    Else
        Command2.Caption = "连续进行"
        Label18.Caption = "连续采集已经停止"
        Label18.ForeColor = &HFF&
        Timer1.Enabled = False
    End If
End Sub

Private Sub Command3_Click()
    MSComm1.PortOpen = False
    MSComm2.PortOpen = False
    MSComm1.CommPort = Right(Combo2.Text, 1)
    MSComm1.Settings = Combo3.Text + Right(Combo4.Text, 1) + "8" + Combo5.Text
    MSComm2.CommPort = Right(Combo1.Text, 1)
    MSComm2.Settings = Combo6.Text + Right(Combo7.Text, 1) + "8" + Combo8.Text
    MSComm1.PortOpen = True
    MSComm2.PortOpen = True
End Sub

Private Sub Command4_Click()
Dim outsize As Integer
    Status = 1
    runstop = Not (runstop)
    If (runstop) Then
        Command4.Caption = "连续暂停"
        Label22.Caption = "进行中…"
        Label22.ForeColor = &HFF00&
        CHchange
        For i = 1 To 8
            If i <> countt Then
                Shape1(i).BackColor = &HFF&             '&H000000FF&红色;&H0000FF00&绿色
            Else
                Shape1(countt).BackColor = &HFF00&
            End If
        Next
        Delay
        Timer2.Enabled = True
    Else
        Command4.Caption = "连续进行"
        Label22.Caption = "已经停止"
        Label22.ForeColor = &HFF&
        Timer2.Enabled = False
    End If
End Sub

Private Sub Command5_Click()
Dim outsize As Integer
    Status = 1
    CHchange
    For i = 1 To 8
        If i <> countt Then
            Shape1(i).BackColor = &HFF&             '&H000000FF&红色;&H0000FF00&绿色
        Else
            Shape1(countt).BackColor = &HFF00&
        End If
    Next
    Read2000
End Sub

Private Sub Form_Load()
    AB() = Array(&H0, &H0, &H10, &H21, &H20, &H42, &H30, &H63, &H40, &H84, &H50, &HA5, &H60, &HC6, &H70, &HE7, &H81, &H8, &H91, &H29, &HA1, &H4A, &HB1, &H6B, &HC1, &H8C, &HD1, &HAD, &HE1, &HCE, &HF1, &HEF, &H12, &H31, &H2, &H10, &H32, &H73, &H22, &H52, &H52, &HB5, &H42, &H94, &H72, &HF7, &H62, &HD6, &H93, &H39, &H83, &H18, &HB3, &H7B, &HA3, &H5A, &HD3, &HBD, &HC3, &H9C, &HF3, &HFF, &HE3, &HDE, &H24, &H62, &H34, &H43, &H4, &H20, &H14, &H1, &H64, &HE6, &H74, &HC7, &H44, &HA4, &H54, &H85, &HA5, &H6A, &HB5, &H4B, &H85, &H28, &H95, &H9, &HE5, &HEE, &HF5, &HCF, &HC5, &HAC, &HD5, &H8D, &H36, &H53, &H26, &H72, &H16, &H11, &H6, &H30, &H76, &HD7, &H66, &HF6, &H56, &H95, &H46, &HB4, &HB7, &H5B, &HA7, &H7A, &H97, &H19, &H87, &H38, &HF7, &HDF, &HE7, &HFE, &HD7, &H9D, &HC7, &HBC, &H48, &HC4, &H58, &HE5, &H68, &H86, &H78, &HA7, &H8, &H40, &H18, &H61, &H28, &H2, &H38, &H23, &HC9, &HCC, &HD9, &HED, &HE9, &H8E, &HF9, &HAF, &H89, &H48, &H99, &H69, &HA9, &HA, &HB9, &H2B, &H5A, &HF5, &H4A, &HD4, &H7A, &HB7, &H6A, &H96, &H1A, _
&H71, &HA, &H50, &H3A, &H33, &H2A, &H12, &HDB, &HFD, &HCB, &HDC, &HFB, &HBF, &HEB, &H9E, &H9B, &H79, &H8B, &H58, &HBB, &H3B, &HAB, &H1A, &H6C, &HA6, &H7C, &H87, &H4C, &HE4, &H5C, &HC5, &H2C, &H22, &H3C, &H3, &HC, &H60, &H1C, &H41, &HED, &HAE, &HFD, &H8F, &HCD, &HEC, &HDD, &HCD, &HAD, &H2A, &HBD, &HB, &H8D, &H68, &H9D, &H49, &H7E, &H97, &H6E, &HB6, &H5E, &HD5, &H4E, &HF4, &H3E, &H13, &H2E, &H32, &H1E, &H51, &HE, &H70, &HFF, &H9F, &HEF, &HBE, &HDF, &HDD, &HCF, &HFC, &HBF, &H1B, &HAF, &H3A, &H9F, &H59, &H8F, &H78, &H91, &H88, &H81, &HA9, &HB1, &HCA, &HA1, &HEB, &HD1, &HC, &HC1, &H2D, &HF1, &H4E, &HE1, &H6F, &H10, &H80, &H0, &HA1, &H30, &HC2, &H20, &HE3, &H50, &H4, &H40, &H25, &H70, &H46, &H60, &H67, &H83, &HB9, &H93, &H98, &HA3, &HFB, &HB3, &HDA, &HC3, &H3D, &HD3, &H1C, &HE3, &H7F, &HF3, &H5E, &H2, &HB1, &H12, &H90, &H22, &HF3, &H32, &HD2, &H42, &H35, &H52, &H14, &H62, &H77, &H72, &H56, &HB5, &HEA, &HA5, &HCB, &H95, &HA8, &H85, &H89, &HF5, &H6E, &HE5, &H4F, &HD5, &H2C, &HC5, &HD, &H34, &HE2, &H24, &HC3, _
&H14, &HA0, &H4, &H81, &H74, &H66, &H64, &H47, &H54, &H24, &H44, &H5, &HA7, &HDB, &HB7, &HFA, &H87, &H99, &H97, &HB8, &HE7, &H5F, &HF7, &H7E, &HC7, &H1D, &HD7, &H3C, &H26, &HD3, &H36, &HF2, &H6, &H91, &H16, &HB0, &H66, &H57, &H76, &H76, &H46, &H15, &H56, &H34, &HD9, &H4C, &HC9, &H6D, &HF9, &HE, &HE9, &H2F, &H99, &HC8, &H89, &HE9, &HB9, &H8A, &HA9, &HAB, &H58, &H44, &H48, &H65, &H78, &H6, &H68, &H27, &H18, &HC0, &H8, &HE1, &H38, &H82, &H28, &HA3, &HCB, &H7D, &HDB, &H5C, &HEB, &H3F, &HFB, &H1E, &H8B, &HF9, &H9B, &HD8, &HAB, &HBB, &HBB, &H9A, &H4A, &H75, &H5A, &H54, &H6A, &H37, &H7A, &H16, &HA, &HF1, &H1A, &HD0, &H2A, &HB3, &H3A, &H92, &HFD, &H2E, &HED, &HF, &HDD, &H6C, &HCD, &H4D, &HBD, &HAA, &HAD, &H8B, &H9D, &HE8, &H8D, &HC9, &H7C, &H26, &H6C, &H7, &H5C, &H64, &H4C, &H45, &H3C, &HA2, &H2C, &H83, &H1C, &HE0, &HC, &HC1, &HEF, &H1F, &HFF, &H3E, &HCF, &H5D, &HDF, &H7C, &HAF, &H9B, &HBF, &HBA, &H8F, &HD9, &H9F, &HF8, &H6E, &H17, &H7E, &H36, &H4E, &H55, &H5E, &H74, &H2E, &H93, &H3E, &HB2, &HE, &HD1, &H1E, &HF0)
    MSComm1.CommPort = Right(Combo2.Text, 1)
    MSComm1.Settings = Combo3.Text + Right(Combo4.Text, 1) + "8" + Combo5.Text
    MSComm1.PortOpen = True
    MSComm2.CommPort = Right(Combo1.Text, 1)
    MSComm2.Settings = Combo6.Text + Right(Combo7.Text, 1) + "8" + Combo8.Text
    MSComm2.PortOpen = True
    Command2.Caption = "连续进行"
    runstop = False
    scan = False
    Timer1.Enabled = False
    Timer2.Enabled = False
    Text3.Text = HScroll1.Value
End Sub

Public Function CHchange()
Dim outdata(3) As Byte
    countt = Val(Text1.Text)
    outdata(0) = &H40
    outdata(1) = &H30
    outdata(2) = Asc(Right(Hex(Text1.Text), 1))
    outdata(3) = &HD
    writecom (outdata)
End Function

Public Function writecom(ByRef outstr)
    flag = True
    MSComm1.InputLen = 0
    MSComm1.InBufferCount = 0
    MSComm1.OutBufferCount = 0
    MSComm1.Output = outstr
    Do
    Loop Until MSComm1.OutBufferCount = 0
    outstr = ""
End Function

Private Sub HScroll1_Change()
    Text3.Text = HScroll1.Value
    Timer2.Interval = Val(Text3.Text)
End Sub

Private Sub Timer1_Timer()
''    ctnl = ctnl + 1
''    If ctnl > 3 Then
''        ctnl = 1
''    End If
''    Select Case ctnl
''        Case 1
''            countt = countt + 1
''            If countt > 8 Then
''                countt = 1
''            End If
''            Text1.Text = Str(countt)
''            For i = 1 To 8  'For i = 1 To 8
''                If i <> countt Then
''                    Shape1(i).BackColor = &HFF&             '&H000000FF&红色;&H0000FF00&绿色
''                Else
''                    Shape1(countt).BackColor = &HFF00&
''                End If
''            Next
''            CHchange
''        Case 2
''            inbuffer = MSComm2.Input
''            MSComm2.InputLen = 0
''        Case 3
            Read2000
''    End Select
End Sub
Public Sub MSComm1_OnComm()
Dim strin As String
Dim strin0 As String
Dim strin1 As String
Dim strin2 As String
Dim i As Integer
Dim j As Integer
Dim inbuffer
    If MSComm1.RThreshold = countt Then
        MSComm1.InputLen = 0
        inbuffer = MSComm1.Input
        inbuffer(countt - 5) = Val("&H" + Chr(inbuffer(countt - 5)) + Chr(inbuffer(countt - 4)))
        inbuffer(countt - 4) = Val("&H" + Chr(inbuffer(countt - 3)) + Chr(inbuffer(countt - 2)))
        inbuffer(countt - 3) = &HD
        CRC (inbuffer)
        If (CH1 = 0 And CL1 = 0) Then
                strin = Chr(inbuffer(3)) + Chr(inbuffer(4))
                Select Case strin
                    Case "RD"
                        strin = Chr(inbuffer(4)) + Chr(inbuffer(5)) + Chr(inbuffer(6)) + Chr(inbuffer(7)) + Chr(inbuffer(8))
                        tempAD = CSng(AD2Dec(Fix(strin0)))
                            strin0 = Chr(inbuffer(j + 8)) + Chr(inbuffer(j + 9)) + Chr(inbuffer(j + 10)) + Chr(inbuffer(j + 11)) + Chr(inbuffer(j + 12)) + Chr(inbuffer(j + 13)) + Chr(inbuffer(j + 14)) + Chr(inbuffer(j + 15))
                            Text7(i + 1).Text = AsctoVal(strin0)
                        Next i
                        j = 133
                        strin0 = Chr(inbuffer(j)) + Chr(inbuffer(j + 1)) + Chr(inbuffer(j + 2)) + Chr(inbuffer(j + 3)) + Chr(inbuffer(j + 4)) + Chr(inbuffer(j + 5)) + Chr(inbuffer(j + 6)) + Chr(inbuffer(j + 7))
                        Text3.Text = AsctoVal(strin0)
                        j = 141
                        strin0 = Chr(inbuffer(j)) + Chr(inbuffer(j + 1)) + Chr(inbuffer(j + 2)) + Chr(inbuffer(j + 3)) + Chr(inbuffer(j + 4)) + Chr(inbuffer(j + 5)) + Chr(inbuffer(j + 6)) + Chr(inbuffer(j + 7))
                        Text2.Text = AsctoVal(strin0)
                    Case "RY"
                        Select Case inbuffer(5)
                            Case 48
                                For i = 0 To 8
                                    j = 6 + i * 16
                                    strin0 = Chr(inbuffer(j)) + Chr(inbuffer(j + 1)) + Chr(inbuffer(j + 2)) + Chr(inbuffer(j + 3)) + Chr(inbuffer(j + 4)) + Chr(inbuffer(j + 5)) + Chr(inbuffer(j + 6)) + Chr(inbuffer(j + 7))
                                    Text9(i + 1).Text = Format(AsctoVal(strin0), "#####00")
                                Next i
                            Case 55
                                If ((Chr(inbuffer(6)) + Chr(inbuffer(7))) = "OK") Then
                                    Label3.Caption = "已经存储"
                                    Label3.ForeColor = &HFF00&
                                End If
                            End Select
                    Case "RZ"
                        Select Case inbuffer(5)
                            Case 48
                                For i = 0 To 8
                                    j = 6 + i * 16
                                    strin0 = Chr(inbuffer(j)) + Chr(inbuffer(j + 1)) + Chr(inbuffer(j + 2)) + Chr(inbuffer(j + 3)) + Chr(inbuffer(j + 4)) + Chr(inbuffer(j + 5)) + Chr(inbuffer(j + 6)) + Chr(inbuffer(j + 7))
                                    Text9(i + 1).Text = Format(AsctoVal(strin0), "#####00")
                                Next i
                            Case 55
                                If ((Chr(inbuffer(6)) + Chr(inbuffer(7))) = "OK") Then
                                    Label4.Caption = "已经存储"
                                    Label4.ForeColor = &HFF00&
                                End If
                            End Select
                    Case "CA"
                        Select Case inbuffer(7)
                            Case 48
                                i = Val(Chr(inbuffer(5)))
                                Text5.Text = i
                                strin0 = Chr(inbuffer(8)) + Chr(inbuffer(9)) + Chr(inbuffer(10)) + Chr(inbuffer(11)) + Chr(inbuffer(12)) + Chr(inbuffer(13)) + Chr(inbuffer(14)) + Chr(inbuffer(15))
                                Text4.Text = strin0
                            Case 55
                                i = Val(Chr(inbuffer(5)))
                                Text5.Text = i
                                If ((Chr(inbuffer(8)) + Chr(inbuffer(9))) = "OK") Then
                                        Label19.Caption = "已标定"
                                        Label19.Visible = True
                                End If
                        End Select
                    Case "##"
                        Text2.Text = Chr(inbuffer(1)) + Chr(inbuffer(2)) + Chr(inbuffer(3)) + Chr(inbuffer(4))
                End Select
        End If
    End If
End Sub
Public Function RAMread()
Dim outdata(9) As Byte
    countt = 15
    outdata(0) = &H40
    outdata(1) = Asc(Text1.Text)
    outdata(2) = &H52
    outdata(3) = &H44
    outdata(4) = &HD
    CRC (outdata)
    outdata(4) = HtoASC(Fix(CH1 / 16))
    outdata(5) = HtoASC(CH1 Mod 16)
    outdata(6) = HtoASC(Fix(CL1 / 16))
    outdata(7) = HtoASC(CL1 Mod 16)
    outdata(8) = &HD
    writecom (outdata)
    MSComm1.RThreshold = countt
End Function

Public Function Delay()
Dim i As Long
    For i = 1 To 120000
    Next i
End Function

Private Sub Timer2_Timer()
Dim temp As Integer
    scan = Not (scan)
    If (scan) Then
        CHchange
    Else
        Read2000
    End If
End Sub

Public Function AD2Dec(ADin As Long) As Long
    If (ADin >= 524288) Then
        AD2Dec = (524288 - (ADin Mod 524288)) * (-1)
    Else
        AD2Dec = ADin
    End If
End Function

Public Function HtoD(Str As String) As Long
Dim i As Integer
Dim t As Integer
    HtoD = 0
    For i = 1 To 5
        Select Case Mid(Str, i, 1)
            Case "A"
                t = 10
            Case "B"
                t = 11
            Case "C"
                t = 12
            Case "D"
                t = 13
            Case "E"
                t = 14
            Case "F"
                t = 15
            Case Else
                t = Val(Mid(Str, i, 1))
        End Select
        HtoD = HtoD + 16 ^ (5 - i) * t
    Next i
End Function

Public Function CRC(ByRef Datastr)
Dim CH0 As Byte
Dim CL0 As Byte
Dim CH00 As Byte
Dim CL00 As Byte
Dim i As Integer
Dim x As String
    CH0 = AB(Asc(Mid(Datastr, 2, 1)) * 2)
    CL0 = AB(Asc(Mid(Datastr, 2, 1)) * 2 + 1)
    For i = 3 To Len(Datastr)
        x = Mid(Datastr, i, 1)
        CH00 = AB((CH0 Xor Asc(x)) * 2)
        CL00 = AB((CH0 Xor Asc(x)) * 2 + 1)
        CH0 = CL0 Xor CH00
        CL0 = CL00
    Next i
    CH1 = CH0
    CL1 = CL0
End Function

Public Function HtoD(Str As String) As Long
Dim i As Integer
Dim t As Integer
    HtoD = 0
    For i = 1 To 5
        Select Case Mid(Str, i, 1)
            Case "A"
                t = 10
            Case "B"
                t = 11
            Case "C"
                t = 12
            Case "D"
                t = 13
            Case "E"
                t = 14
            Case "F"
                t = 15
            Case Else
                t = Val(Mid(Str, i, 1))
        End Select
        HtoD = HtoD + 16 ^ (5 - i) * t
    Next i
End Function

Public Function AD2Dec(ADin As Long) As Long
    If (ADin >= 524288) Then
        AD2Dec = (524288 - (ADin Mod 524288)) * (-1)
    Else
        AD2Dec = ADin
    End If
End Function