發表于：2002/11/11 21:44:00
#0樓
本人最近為了實現電腦與Delta VFD-M變頻器通訊，特意用VB6.0編了一個Modbus協議通訊軟件，不過這只是一個測試版，但Modbus的ASCii協議和RTU協議都已經實現?，F在將源程序上貼，希望可以幫助到有需要的朋友，謝謝！(我發現圖片貼不上去）
另外，假如你覺得有更好的想法，歡迎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
