Modbus 通讯协议编程

本人最近为了实现电脑与Delta VFD-M变频器通讯，特意用VB6.0编了一个Modbus协议通讯软件，不过这只是一个测试版，但Modbus的ASCii协议和RTU协议都已经实现。现在将源程序上贴，希望可以帮助到有需要的朋友，谢谢！(我发现图片贴不上去）

    另外，假如你觉得有更好的想法，欢迎E-mail指教。

附：VB6源程序

Option Explicit

Private Text1text As String

Private RTUCRC As String

'串口选择

Private Sub Combo1_Click()

              MSComm1.CommPort = Combo1.ListIndex + 1

End Sub

'数据位改变

Private Sub Combo2_Click()

        Call setting

End Sub

'波特率改变

Private Sub Combo3_Click()

        Call setting

End Sub

'奇偶校验改变

Private Sub Combo4_Click()

        Call setting

End Sub

'停止位改变

Private Sub Combo5_Click()

        Call setting

End Sub

Private Sub setting()

         MSComm1.Settings = CStr(Combo3.Text) & 

                                          & 

End Sub

'打开关闭串口

Private Sub Command1_Click()

        On Error Resume Next

        If MSComm1.PortOpen = False Then

            MSComm1.PortOpen = True

        Else

               MSComm1.PortOpen = False

        End If

        If MSComm1.PortOpen Then                                '打开关闭按钮显示文字及combo1使能

             Command1.Caption = "关闭串口"

             Combo1.Enabled = False

        Else

              Command1.Caption = "打开串口"

              Combo1.Enabled = True

        End If

          If Err Then                                                          '打开串口失败，则显示出错信息

               MsgBox Error$, 48, "错误信息"

                Exit Sub

           End If

End Sub

'10转16进制

Private Sub Command2_Click(Index As Integer)

     On Error Resume Next

         Text4.Text = Hex(Text3.Text)

           If Err Then                                                          ''则显示出错信息

               MsgBox Error$, 48, "错误信息"

                Exit Sub

           End If

End Sub

'16转10进制

Private Sub Command3_Click()

         Dim a As Long

         a = Val("&H" & CStr(Text4.Text))

         Text3.Text = a

End Sub

'手动串口发送

Private Sub Command4_Click()

         If MSComm1.PortOpen = False Then

                  MsgBox "请先打开串口", , "错误信息"

                  Exit Sub

          End If

          Call sentsub

End Sub

'清除接收窗

Private Sub Command5_Click()

          Text2.Text = ""

End Sub

Private Sub Command6_Click()

        Unload Me

End Sub

Private Sub Command7_Click()

        On Error Resume Next

          Dim STP As String

           STP = CStr(Chr(2)) & "010001" & CStr(Chr(3)) & "25"

           MSComm1.Settings = "9600,N,7,2"

           MSComm1.PortOpen = True

           MSComm1.Output = STP

           MSComm1.PortOpen = False

           If Err Then                                                          '打开串口失败，则显示出错信息

               MsgBox Error$, 48, "错误信息"

                Exit Sub

           End If

End Sub

Private Sub Command8_Click()

        On Error Resume Next

        Dim FWD As String

           FWD = CStr(Chr(2)) & "010101" & CStr(Chr(3)) & "26"

           MSComm1.Settings = "9600,N,7,2"

           MSComm1.PortOpen = True

           MSComm1.Output = FWD

           MSComm1.PortOpen = False

           If Err Then                                                          '打开串口失败，则显示出错信息

               MsgBox Error$, 48, "错误信息"

                Exit Sub

           End If

End Sub

Private Sub Command9_Click()

        On Error Resume Next

           Dim REV As String

           REV = CStr(Chr(2)) & "010201" & CStr(Chr(3)) & "27"

           MSComm1.Settings = "9600,N,7,2"

           MSComm1.PortOpen = True

           MSComm1.Output = REV

           MSComm1.PortOpen = False

           If Err Then                                                          '打开串口失败，则显示出错信息

               MsgBox Error$, 48, "错误信息"

                Exit Sub

           End If

End Sub

'窗口加载

Private Sub Form_Load()

         Dim d%

            For d = 1 To 16

                   Combo1.AddItem ("COM" & CStr(d))

            Next

                   Combo1.ListIndex = 0

            Combo2.AddItem "6"

            Combo2.AddItem "7"

            Combo2.AddItem "8"

            Combo2.ListIndex = 2

            Combo3.AddItem "110"

            Combo3.AddItem "330"

            Combo3.AddItem "1200"

            Combo3.AddItem "2400"

            Combo3.AddItem "4800"

            Combo3.AddItem "9600"

            Combo3.AddItem "19200"

            Combo3.AddItem "38400"

            Combo3.AddItem "56000"

            Combo3.AddItem "57600"

            Combo3.AddItem "115200"

            Combo3.ListIndex = 5

            Combo4.AddItem "n"

            Combo4.AddItem "o"

            Combo4.AddItem "e"

            Combo4.ListIndex = 0

            Combo5.AddItem "1"

            Combo5.AddItem "2"

            Combo5.ListIndex = 0

            For d = 0 To 254

                Combo6.AddItem d

            Next

                Combo6.ListIndex = 1

         Text1.Text = "010601001770"

         Text2.Text = ""

         Text3.Text = ""

         Text4.Text = ""

         Text5.Text = "1000"

         Text6.Text = "06"

         Text7.Text = "0"

         Text8.Text = "1"

         Option1.value = True

         Option3.value = True

         Option7.value = True

         Option9.value = True

         If MSComm1.PortOpen = False Then

                Command1.Caption = "打开串口"

         Else

                Command1.Caption = "关闭串口"

         End If

End Sub

'串口接收程序

Private Sub MSComm1_OnComm()

        Dim Hexchr As String, hexstring As String, i As Integer, j As Integer, hexdisp As String

        If Option8.value Then

             hexstring = MSComm1.Input                                                                    '十六进制显示

            i = Len(hexstring)

             For j = 1 To i

                 Hexchr = Mid(hexstring, j, 1)

                 If Hex(Asc(Hexchr)) < 16 Then

                    Text2.Text = Text2.Text & "0" & Hex(Asc(Hexchr)) & " "

                 Else

                    Text2.Text = Text2.Text & Hex(Asc(Hexchr)) & " "

                End If

            Next j

            Text2.Text = Text2.Text & CStr(Chr(13)) & CStr(Chr(10))

        Else

            Text2.Text = Text2.Text & MSComm1.Input & CStr(Chr(13)) & CStr(Chr(10))   'ASCII码显示

        End If

End Sub

'手动发送选择

Private Sub Option1_Click()

         If Option1.value = True Then

              Timer1.Enabled = False

              Command4.Enabled = True

        Else

              Timer1.Enabled = True

              Command4.Enabled = False

        End If

End Sub

'Delta ASCII发送协议

Private Sub Option10_Click()

        Combo6.Enabled = True

       Text6.Enabled = True

       Text7.Enabled = True

       Text8.Enabled = True

       Label10.Enabled = True

       Label11.Enabled = True

       Label12.Enabled = True

       Label13.Enabled = True

       Option6.Enabled = False

       Option7.Enabled = False

       Option11.value = True

       Combo2.ListIndex = 1

       Combo5.ListIndex = 1

       Text1.Enabled = False

       Label14.Enabled = False

       Frame7.Visible = True

End Sub

'自动发送选择

Private Sub Option2_Click()

         If Option2.value = True Then

              Timer1.Enabled = True

              Command4.Enabled = False

        Else

              Timer1.Enabled = False

              Command4.Enabled = True

        End If

End Sub

Private Sub Option3_Click()               'Non选项

       Combo6.Enabled = False

       Text6.Enabled = False

       Text7.Enabled = False

       Text8.Enabled = False

       Label10.Enabled = False

       Label11.Enabled = False

       Label12.Enabled = False

       Label13.Enabled = False

       Option6.Enabled = True

       Option7.Enabled = True

       Combo2.ListIndex = 2

       Combo5.ListIndex = 0

       Text1.Enabled = True

       Label14.Enabled = True

       Frame7.Visible = False

End Sub

Private Sub Option4_Click()               'ASCII选项

       Combo6.Enabled = True

       Text6.Enabled = True

       Text7.Enabled = True

       Text8.Enabled = True

       Label10.Enabled = True

       Label11.Enabled = True

       Label12.Enabled = True

       Label13.Enabled = True

       Option6.Enabled = False

       Option7.Enabled = False

       Combo2.ListIndex = 1

       Combo5.ListIndex = 1

       Text1.Enabled = False

       Label14.Enabled = False

       Frame7.Visible = False

End Sub

Private Sub Option5_Click()               'RTU选项

       Combo6.Enabled = True

       Text6.Enabled = True

       Text7.Enabled = True

       Text8.Enabled = True

       Label10.Enabled = True

       Label11.Enabled = True

       Label12.Enabled = True

       Label13.Enabled = True

       Option6.Enabled = False

       Option7.Enabled = False

       Combo2.ListIndex = 2

       Combo5.ListIndex = 1

       Text1.Enabled = False

       Label14.Enabled = False

       Frame7.Visible = False

End Sub

'发送时间间隔调整输入

Private Sub Text5_Change()

        Dim number As String

        Dim num As Integer

        Dim numcyc As Integer

        num = Len(Text5.Text)

        For numcyc = 1 To num

            number = Mid(Text5.Text, numcyc, 1)

            Select Case InStr("01234567", number)

            Case 0

               MsgBox "输入时间间隔错误，请重新输入", , "错误信息"

               Exit Sub

            End Select

        Next

         Timer1.Interval = Text5.Text

End Sub

'自动发送定时器

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("01234567ABCDEFabcdef", 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("01234567", 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("01234567", 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