Modbus 通讯协议编程(VB源代码)

最近，本人为了实现电脑与Delta V FD-M变频器通讯，特意用VB6.0编了一个Modbus协议通讯软件。

这只是一个测试版，但Modbus的ASCII协议和RTU协议都已经实现。

现在将源程序上传，希望可以帮助到有需要的朋友，谢谢！

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

如果对本程序有任何意见和建议，也可以一起讨论，共同进步。

大家多多支持俺啊。

附：VB6源程序

Option Explicit

Private Text1text As String

Private RTUCRC As String

'串口选择

Private Sub Combo1_Click()

rt = dex + 1

End Sub

'数据位改变< span style="color: #008000;">

Private Sub Combo2_Click()

Call setting

End Sub

'波特率改变< span style="color: #008000;">

Private Sub Combo3_Click()

Call setting

End Sub

'奇偶校验改变< span style="color: #008000;">

Private Sub Combo4_Click()

Call setting

End Sub

'停止位改变< span style="color: #008000;">

Private Sub Combo5_Click()

Call setting

End Sub

Private Sub setting()

gs = CStr() & "," & CStr() & "," & CStr() _

& "," & CStr()

End Sub

'打开关闭串口< span style="color: #008000;">

Private Sub Command1_Click()

On Error Resume Next

If en = False Then

en = True

Else

en = False

End If

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

n = "关闭串口"

d = False

Else

n = "打开串口"

d = True

End If

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

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

Exit Sub

End If

End Sub

'10转16进制< span style="color: #008000;">

Private Sub Command2_Click(Index As Integer)

On Error Resume Next

= Hex()

If Err Then ''则显示出错信息< span style="color: #008000;">

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

Exit Sub

End If

End Sub

'16转10进制< span style="color: #008000;">

Private Sub Command3_Click()

Dim a As Long

a = Val("&H" & CStr())

= a

End Sub

'手动串口发送< span style="color: #008000;">

Private Sub Command4_Click()

If en = False Then

MsgBox "请先打开串口< span style="color: #800000;">", , "错误信息"

Exit Sub

End If

Call sentsub

End Sub

'清除接收窗< span style="color: #008000;">

Private Sub Command5_Click()

= ""

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"

gs = "9600,N,7,2"

en = True

= STP

en = 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"

gs = "9600,N,7,2"

en = True

= FWD

en = 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"

gs = "9600,N,7,2"

en = True

= REV

en = False

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

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

Exit Sub

End If

End Sub

'窗口加载

Private Sub Form_Load()

Dim d%

For d = 1 To 16

m ("COM" & CStr(d))

Next

dex = 0

m "6"

m "7"

m "8"

dex = 2

m "110"

m "330"

m "1200"

m "2400"

m "4800"

m "9600"

m "19200"

m "38400"

m "56000"

m "57600"

m "115200"

dex = 5

m "n"

m "o"

m "e"

dex = 0

m "1"

m "2"

dex = 0

For d = 0 To 254

m d

Next

dex = 1

= ""

= ""

= ""

= ""

= "1000"

= "06"

= "0"

= "1"

= True

= True

= True

= True

If en = False Then

n = "打开串口"

Else

n = "关闭串口"

End If

End Sub

'串口接收程序< span style="color: #008000;">

Private Sub MSComm1_OnComm()

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

If Then

hexstring = '十六进制显示< span style="color: #008000;">

i = Len(hexstring)

For j = 1 To i

Hexchr = Mid(hexstring, j, 1)

If Hex(Asc(Hexchr)) < 16 Then

= & "0" & Hex(Asc(Hexchr)) & " "

Else

= & Hex(Asc(Hexchr)) & " "

End If

Next j

= & CStr(Chr(13)) & CStr(Chr(10))

Else

= & & CStr(Chr(13)) & CStr(Chr(10)) 'ASCII码显示< span style="color: #008000;">

End If

End Sub

'手动发送选择< span style="color: #008000;">

Private Sub Option1_Click()

If = True Then

d = False

d = True

Else

d = True

d = False

End If

End Sub

'Delta ASCII发送协议

Private Sub Option10_Click()

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = False

d = False

= True

dex = 1

dex = 1

d = False

d = False

e = True

End Sub

'自动发送选择< span style="color: #008000;">

Private Sub Option2_Click()

If = True Then

d = True

d = False

Else

d = False

d = True

End If

End Sub

Private Sub Option3_Click() 'Non选项< span style="color: #008000;">

d = False

d = False

d = False

d = False

d = False

d = False

d = False

d = False

d = True

d = True

dex = 2

dex = 0

d = True

d = True

e = False

End Sub

Private Sub Option4_Click() 'ASCII选项< span style="color: #008000;">

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = False

d = False

dex = 1

dex = 1

d = False

d = False

e = False

End Sub

Private Sub Option5_Click() 'RTU选项< span style="color: #008000;">

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = True

d = False

d = False

dex = 2

dex = 1

d = False

d = False

e = False

End Sub

'发送时间间隔调整输入< span style="color: #008000;">

Private Sub Text5_Change()

Dim number As String

Dim num As Integer

Dim numcyc As Integer

num = Len()

For numcyc = 1 To num

number = Mid(, numcyc, 1)

Select Case InStr("", number)

Case 0

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

Exit Sub

End Select

Next

al =

End Sub

'自动发送定时器< span style="color: #008000;">

Private Sub Timer1_Timer()

If en Then

Call sentsub

End If

End Sub

'状态刷新定时器< span style="color: #008000;">

Private Sub Timer2_Timer()

(1).Text = "串口选择：< span style="color: #800000;">" & CStr()

(2).Text = "串口设置：< span style="color: #800000;">" & CStr(gs)

(3).Text = "串口状态：< span style="color: #800000;">" & CStr(en)

End Sub

'串口发送子程序

Private Sub sentsub()

Dim optioncase%

If Then optioncase = 1

If Then optioncase = 2

If Then optioncase = 3

If Then optioncase = 4

Select Case optioncase

Case 1

If Then

Text1text =

Call Hexsent

Else

Text1text =

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

'十六进制发送< span style="color: #008000;">

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("ABCDEFabcdef", Hexchr) = 0 Then

MsgBox "无效的数值，请重新输入< span style="color: #800000;">", , "错误信息"

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

' = CStr(hexmid)

Next

= hexchrgroup

End Sub

'ASC码发送< span style="color: #008000;">

Private Sub ASCIIsent()

= 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))) '两个两个的取字符< span style="color: #008000;">

checksum = checksum + char '全部加起来< span style="color: #008000;">

Next

AscLrc = checksum Mod &H100 '取255的余数< span style="color: #008000;">

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)) '两个两个的取字符< span style="color: #008000;">

checksum = checksum + char '全部加起来< span style="color: #008000;">

Next

Lrc = (checksum + &H3) Mod &H100 '取255的余数< span style="color: #008000;">

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校验< span style="color: #008000;">

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() & CStr() & CStr() & CStr()

wc = Len(wholechar)

For wcyc = 1 To wc

wchar = Mid(wholechar, wcyc, 1)

If InStr("", wchar) = 0 Then

MsgBox "输入错误，请重新输入< span style="color: #800000;">", , "错误提示"

Exit Sub

End If

Next

SIDnum = Len(CStr(Hex()))

Select Case SIDnum

Case 0

Exit Sub

Case 1

SID = "0" & CStr(Hex())

Case 2

SID = CStr(Hex())

End Select

Cmdnum = Len(CStr(Hex()))

Select Case Cmdnum

Case 0

Exit Sub

Case 1

Cmd = "0" & CStr(Hex())

Case 1

Cmd = CStr(Hex())

End Select

InfoAddNum = Len(CStr(Hex()))

Select Case InfoAddNum

Case 0

Exit Sub

Case 1

InfoAdd = "000" & CStr(Hex())

Case 2

InfoAdd = "00" & CStr(Hex())

Case 3

InfoAdd = "0" & CStr(Hex())

Case 4

InfoAdd = CStr(Hex())

End Select

Datanum = Len(CStr(Hex()))

Select Case Datanum

Case 0

Exit Sub

Case 1

data = "000" & CStr(Hex())

Case 2

data = "00" & CStr(Hex())

Case 3

data = "0" & CStr(Hex())

Case 4

data = CStr(Hex())

End Select

If Err Then '显示出错信息< span style="color: #008000;">

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() & CStr() & CStr()

wc = Len(wholechar)

For wcyc = 1 To wc

wchar = Mid(wholechar, wcyc, 1)

If InStr("", wchar) = 0 Then

MsgBox "输入错误，请重新输入< span style="color: #800000;">", , "错误提示"

Exit Sub

End If

Next

SIDnum = Len(CStr(Hex()))

Select Case SIDnum

Case 0

Exit Sub

Case 1

SID = "0" & CStr(Hex())

Case 2

SID = CStr(Hex())

End Select

'Cmdnum = Len(CStr(Hex()))

'Select Case Cmdnum

'Case 0

' Exit Sub

'Case 1

' Cmd = "0" & CStr(Hex())

'Case 1

' Cmd = CStr(Hex())

'End Select

InfoAddNum = Len(CStr(Hex()))

Select Case InfoAddNum

Case 0

Exit Sub

Case 1

InfoAdd = "0" & CStr(Hex())

Case 2

InfoAdd = CStr(Hex())

End Select

Datanum = Len(CStr(Hex()))

Select Case Datanum

Case 0

Exit Sub

Case 1

data = "000" & CStr(Hex())

Case 2

data = "00" & CStr(Hex())

Case 3

data = "0" & CStr(Hex())

Case 4

data = CStr(Hex())

End Select

If Err Then '显示出错信息< span style="color: #008000;">

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

Exit Sub

End If

If 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寄存器< span style="color: #008000;">

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 '高位右移一位< span style="color: #008000;">

CRC16Lo = CRC16Lo 2 '低位右移一位< span style="color: #008000;">

If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1< span style="color:

#008000;">

CRC16Lo = CRC16Lo Or &H80 '则低位字节右移后前面补1< span style="color: #008000;">

End If '否则自动补0< span style="color: #008000;">

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