Modbus 通讯协议编程

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) & "," & CStr(Combo4.Text) & "," & CStr(Combo2.Text) _
& "," & CStr(Combo5.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("0123456789", 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

\'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

上传工程吧，楼主。谢谢了。