发表于：2002/11/11 21:44:00
#0楼
本人最近为了实现电脑与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) & "," & 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
'串口发送子程序
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
另外，假如你觉得有更好的想法，欢迎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) & "," & 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
'串口发送子程序
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
