文本文档.txt

vb通讯程序

Private Sub Timer1_Timer()
         If MSComm1.PortOpen Then
               Call sentsub
         End If
End Sub
'状态刷新定时器
Private Sub Timer2_Timer()
         StatusBar1.Panels(1).Text = "串口选择：" & CStr(Combo1.Text)
         StatusBar1.Panels(2).Text = "串口设置：" & CStr(MSComm1.Settings)
         StatusBar1.Panels(3).Text = "串口状态：" & CStr(MSComm1.PortOpen)
End Sub
'串口发送子程序
Private Sub sentsub()
             Dim optioncase%
             If Option3.value Then optioncase = 1
             If Option4.value Then optioncase = 2
             If Option5.value Then optioncase = 3
             If Option10.value Then optioncase = 4
             Select Case optioncase
             Case 1
                     If Option6.value Then
                       Text1text = Text1.Text
                       Call Hexsent
                     Else
                       Text1text = Text1.Text
                       Call ASCIIsent
                     End If
             Case 2
                  Call incorporate                '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call ASCIIcheck
                  Call ASCIIsent
             Case 3
                  Call incorporate                 '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call RTUcheck
                  Call Hexsent
             Case 4
                  Call incorporate1                '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
                  Call deltaASCII
                  Call ASCIIsent
            End Select
End Sub
'十六进制发送
Private Sub Hexsent()
            Dim hexchrlen%, Hexchr As String, hexcyc%, hexmid As Byte, hexmiddle As String
            Dim hexchrgroup() As Byte, i As Integer
               hexchrlen = Len(Text1text)
               For hexcyc = 1 To hexchrlen                                                  '检查Text1文本框内数值是否合适
               Hexchr = Mid(Text1text, hexcyc, 1)
               If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
                     MsgBox "无效的数值，请重新输入", , "错误信息"
                     Exit Sub
                End If
               Next
               ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
               For hexcyc = 1 To hexchrlen Step 2                                         '将文本框内数值分成两个、两个
                     i = i + 1
                     Hexchr = Mid(Text1text, hexcyc, 2)
                     hexmid = Val("&H" & CStr(Hexchr))
                     hexchrgroup(i) = hexmid
                     'MSComm1.Output = CStr(hexmid)
               Next
               MSComm1.Output = hexchrgroup
End Sub
'ASC码发送
Private Sub ASCIIsent()
                MSComm1.Output = Text1text
End Sub
'ASC校验,此段程序计算出LRC校验值，并加上字头和字尾
Private Sub ASCIIcheck()
         Dim a%, b%, chrnum%, Lrcbyte As String
         Dim checksum%, char%, AscLrc%, Lrc%
         
         chrnum = Len(Text1text)
         For a = 1 To chrnum Step 2
            char = Val("&H" & CStr(Mid(Text1text, a, 2)))   '两个两个的取字符
            checksum = checksum + char                      '全部加起来
         Next
         AscLrc = checksum Mod &H100                        '取255的余数
         Lrc = (&HFF - AscLrc) + 1                                '取二次补
         If Lrc < 16 Then                                               '此段程序是判断Hex(lrc)是否是一位数，
             Lrcbyte = "0" + CStr(Hex(Lrc))                     '如果是的话，前面加0；否则不加零
        Else
            Lrcbyte = CStr(Hex(Lrc))
        End If
         Text1text = CStr(Chr(58)) & CStr(Text1text) & Lrcbyte & CStr(Chr(13)) & CStr(Chr(10))
End Sub
'DeltaASCII校验,此段程序计算出LRC校验值，并加上字头和字尾
Private Sub deltaASCII()
         Dim a%, b%, chrnum%, Lrcbyte As String
         Dim checksum%, char%, Lrc%
                  
         chrnum = Len(Text1text)
         For a = 1 To chrnum
            char = Asc(Mid(Text1text, a, 1))   '两个两个的取字符
            checksum = checksum + char                      '全部加起来
         Next
         Lrc = (checksum + &H3) Mod &H100                       '取255的余数
         If Lrc < 16 Then                                               '此段程序是判断Hex(lrc)是否是一位数，
             Lrcbyte = "0" + CStr(Hex(Lrc))                     '如果是的话，前面加0；否则不加零
        Else
            Lrcbyte = CStr(Hex(Lrc))
        End If
         Text1text = CStr(Chr(2)) & CStr(Text1text) & CStr(Chr(3)) & Lrcbyte
End Sub

'RTU校验
Private Sub RTUcheck()
        Dim CRC() As Byte
        Dim d(5) As Byte
        Dim string1 As String
        Dim j As Integer, chrlength As Integer, temp As String
        
        string1 = Text1text
        chrlength = Len(string1)
        For j = 0 To chrlength / 2 - 1
                  temp = Mid(string1, j * 2 + 1, 2)
                  d(j) = Val("&H" & temp)
        Next
        RTUCRC = CRC16(d)                         '调用CRC16计算函数, CRC(0)为高位,  CRC(1)为低位
        Text1text = Text1text & RTUCRC
End Sub
Private Sub incorporate()                                       '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
       Dim wholechar As String, wc%, wcyc%, wchar As String
       Dim SID As String, Cmd As String, InfoAdd As String, data As String
       Dim SIDnum%, Cmdnum%, InfoAddNum%, Datanum%
       
      On Error Resume Next
        wholechar = CStr(Combo6.Text) & CStr(Text6.Text) & CStr(Text7.Text) & CStr(Text8.Text)
        wc = Len(wholechar)
        For wcyc = 1 To wc
            wchar = Mid(wholechar, wcyc, 1)
            If InStr("0123456789", wchar) = 0 Then
                MsgBox "输入错误，请重新输入", , "错误提示"
                Exit Sub
            End If
        Next

             SIDnum = Len(CStr(Hex(Combo6.Text)))
              Select Case SIDnum
              Case 0
                Exit Sub
             Case 1
                 SID = "0" & CStr(Hex(Combo6.Text))
             Case 2
                 SID = CStr(Hex(Combo6.Text))
             End Select

             Cmdnum = Len(CStr(Hex(Text6.Text)))
             Select Case Cmdnum
             Case 0
                Exit Sub
             Case 1
                  Cmd = "0" & CStr(Hex(Text6.Text))
             Case 1
                  Cmd = CStr(Hex(Text6.Text))
             End Select
             
             InfoAddNum = Len(CStr(Hex(Text7.Text)))
             Select Case InfoAddNum
             Case 0
                Exit Sub
             Case 1
                  InfoAdd = "000" & CStr(Hex(Text7.Text))
             Case 2
                  InfoAdd = "00" & CStr(Hex(Text7.Text))
             Case 3
                  InfoAdd = "0" & CStr(Hex(Text7.Text))
             Case 4
                  InfoAdd = CStr(Hex(Text7.Text))
            End Select
                  
             Datanum = Len(CStr(Hex(Text8.Text)))
             Select Case Datanum
             Case 0
                Exit Sub
             Case 1
                  data = "000" & CStr(Hex(Text8.Text))
             Case 2
                  data = "00" & CStr(Hex(Text8.Text))
             Case 3
                  data = "0" & CStr(Hex(Text8.Text))
             Case 4
                  data = CStr(Hex(Text8.Text))
            End Select
            
           If Err Then                                                          '显示出错信息
               MsgBox Error$, 48, "错误信息"
                Exit Sub
           End If
            Text1text = CStr(SID) & CStr(Cmd) & CStr(InfoAdd) & CStr(data)
End Sub
Private Sub incorporate1()                                       '将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
       Dim wholechar As String, wc%, wcyc%, wchar As String
       Dim SID As String, Cmd As String, InfoAdd As String, data As String
       Dim SIDnum%, Cmdnum%, InfoAddNum%, Datanum%
       
      On Error Resume Next
        wholechar = CStr(Combo6.Text) & CStr(Text7.Text) & CStr(Text8.Text)
        wc = Len(wholechar)
        For wcyc = 1 To wc
            wchar = Mid(wholechar, wcyc, 1)
            If InStr("0123456789", wchar) = 0 Then
                MsgBox "输入错误，请重新输入", , "错误提示"
                Exit Sub
            End If
        Next

             SIDnum = Len(CStr(Hex(Combo6.Text)))
              Select Case SIDnum
              Case 0
                Exit Sub
             Case 1
                 SID = "0" & CStr(Hex(Combo6.Text))
             Case 2
                 SID = CStr(Hex(Combo6.Text))
             End Select

            'Cmdnum = Len(CStr(Hex(Text6.Text)))
             'Select Case Cmdnum
             'Case 0
             '   Exit Sub
             'Case 1
             '     Cmd = "0" & CStr(Hex(Text6.Text))
             'Case 1
             '     Cmd = CStr(Hex(Text6.Text))
             'End Select
             
             InfoAddNum = Len(CStr(Hex(Text7.Text)))
             Select Case InfoAddNum
             Case 0
                Exit Sub
             Case 1
                  InfoAdd = "0" & CStr(Hex(Text7.Text))
             Case 2
                  InfoAdd = CStr(Hex(Text7.Text))
            End Select
                  
             Datanum = Len(CStr(Hex(Text8.Text)))
             Select Case Datanum
             Case 0
                Exit Sub
             Case 1
                  data = "000" & CStr(Hex(Text8.Text))
             Case 2
                  data = "00" & CStr(Hex(Text8.Text))
             Case 3
                  data = "0" & CStr(Hex(Text8.Text))
             Case 4
                  data = CStr(Hex(Text8.Text))
            End Select
            
           If Err Then                                                          '显示出错信息
               MsgBox Error$, 48, "错误信息"
                Exit Sub
           End If
            
            If Option11.value Then
                  Cmd = "08"
                  Text1text = CStr(SID) & CStr(Cmd) & CStr(InfoAdd)
             Else
                  Cmd = "07"
                  Text1text = CStr(SID) & CStr(Cmd) & CStr(InfoAdd) & CStr(data)
            End If
            
End Sub
Private Function CRC16(data() As Byte) As String
      Dim CRC16Lo As Byte, CRC16Hi As Byte      'CRC寄存器
      Dim CL As Byte, CH As Byte                '多项式码&HA001
      Dim CRCLo As String, CRCHi As String
      Dim SaveHi As Byte, SaveLo As Byte
      Dim i As Integer
      Dim Flag As Integer
      CRC16Lo = &HFF
      CRC16Hi = &HFF
      CL = &H1
      CH = &HA0
      For i = 0 To UBound(data)
        CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
        For Flag = 0 To 7
          SaveHi = CRC16Hi
          SaveLo = CRC16Lo
          CRC16Hi = CRC16Hi \ 2            '高位右移一位
          CRC16Lo = CRC16Lo \ 2            '低位右移一位
          If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
            CRC16Lo = CRC16Lo Or &H80      '则低位字节右移后前面补1
          End If                           '否则自动补0
          If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
            CRC16Hi = CRC16Hi Xor CH
            CRC16Lo = CRC16Lo Xor CL
          End If
        Next Flag
      Next i
      If Len(Hex(CRC16Hi)) = 1 Then
         CRCHi = "0" + Hex(CRC16Hi)
      Else
         CRCHi = Hex(CRC16Hi)
      End If
      If Len(Hex(CRC16Lo)) = 1 Then
         CRCLo = "0" + Hex(CRC16Lo)
      Else
         CRCLo = Hex(CRC16Lo)
      End If
         CRC16 = CRCLo + CRCHi
  End Function