‘用VB 写的 modbus rtu模式通讯源码, 以在台达PLC上调试通过
Private Sub CmdOpen_Click()
On Error Resume Next
If (MSComm1.PortOpen) Then ‘打开/关闭串口
MSComm1.PortOpen = False
Else
MSComm1.PortOpen = True
End If
If (MSComm1.PortOpen) Then
CmdOpen.Caption = "关闭串口"
Shape5.FillStyle = vbFSSolid
Else
CmdOpen.Caption = "打开串口"
Shape5.FillStyle = vbFSTransparent
End If
If Err Then
MsgBox Error$, 48, "错误码信息"
Exit Sub
End If
End Sub
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 Command1_Click()
‘Shape1.FillStyle = vbFSSolid
Dim Y0_status As Byte
Dim Sendstr As String
Dim i As Integer, j As Integer
Sendstr = "01 01 05 00 00 10 "
HexSend (Sendstr)
Sleep (30)
HexSend (Sendstr)
End Sub
Private Function HexSend(Sendstr As String) As Integer
Dim outbuf() As Byte
Dim Temp(0) As Byte
Dim crc As String, Sendstrls As String
Dim sendlen As Integer
Dim i As Integer, j As Integer
If Sendstr = "" Then
MsgBox "发送数据不能为空!"
HexSend = 0
Exit Function
End If
Sendstrls = Trim(Sendstr) ‘去掉空格
sendlen = Len(Sendstrls) + 1 ‘取长度
j = 0
ReDim outbuf(1 To sendlen \ 3) As Byte
For i = 1 To sendlen Step 3
j = j + 1
outbuf(j) = Val("&H" & CStr(Mid(Sendstrls, i, 2)))
Next i
crc = Crc16(outbuf)
ReDim Preserve outbuf(1 To (sendlen \ 3 + 2)) As Byte ‘加上CRC校验码
outbuf(sendlen \ 3 + 1) = Val("&H" & CStr(Mid(crc, 1, 2)))
outbuf(sendlen \ 3 + 2) = Val("&H" & CStr(Mid(crc, 3, 2)))
For i = 1 To (sendlen \ 3 + 2)
Temp(0) = outbuf(i)
MSComm1.Output = Temp
Next i
For i = 1 To 2000
Next i
HexSend = 1
End Function
Private Function Setting()
MSComm1.Settings = CStr(Combo2.Text) & "," & CStr(Combo3.Text) & "," & CStr(Combo4.Text) & "," & CStr(Combo5.Text)
End Function
Private Sub Command2_Click()
‘If (MSComm1.RThreshold = 0) Then
‘MSComm1.RThreshold = 1
‘Else
‘MSComm1.RThreshold = 0
‘End If
Label11.Caption = "接收个数:" & CStr(ReceCount) & " " & "接收帧数:" & CStr(Framecount)
End Sub
Private Sub Form_Load()
Combo1.AddItem ("COM1")
Combo1.AddItem ("COM2")
Combo1.AddItem ("COM3")
Combo1.AddItem ("COM4")
Combo1.AddItem ("COM5")
Combo1.ListIndex = 0
Combo2.AddItem ("2400")
Combo2.AddItem ("4800")
Combo2.AddItem ("9600")
Combo2.AddItem ("11520")
Combo2.ListIndex = 0
Combo3.AddItem ("E")
Combo3.AddItem ("O")
Combo3.AddItem ("N")
Combo3.ListIndex = 2
Combo4.AddItem ("6")
Combo4.AddItem ("7")
Combo4.AddItem ("8")
Combo4.ListIndex = 2
Combo5.AddItem ("1")
Combo5.AddItem ("2")
Combo5.ListIndex = 0
ReceCount = 0
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 = 1 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
Private Sub MSComm1_OnComm()
Dim inpu() As Byte
Dim i As Integer
Dim tempstr As String, Strdata As String
Select Case MSComm1.CommEvent
Case comEvReceive ‘接收事件
tempstr = MSComm1.Input
inpu() = tempstr
Framecount = Framecount + 1 ‘帧个数加1
If (Framecount = 1) Then
framepoint(Framecount) = UBound(inpu) + 1 ‘第一帧帧尾
Else
framepoint(Framecount) = framepoint(Framecount - 1) + UBound(inpu) + 1 ‘第二帧开始指针
End If
For i = 0 To UBound(inpu) ‘将字符转换为数组
If (Len(Hex(inpu(i))) = 1) Then
Strdata = Strdata & "0" & Hex(inpu(i)) & " "
Else
Strdata = Strdata & Hex(inpu(i)) & " "
End If
Next i
For i = ReceCount + 1 To UBound(inpu) + 1 ‘数据进入缓冲区
Recebuf(i) = inpu(i - 1)
Next
ReceCount = ReceCount + UBound(inpu) + 1
TextReceive.Text = TextReceive.Text & Strdata
Strdata = ""
Case comEvSend
End Select
End Sub
Private Function RtuCheck(data() As Byte) As Integer
Dim CrcHi As Byte, CrcLo As Byte
Dim Checkdata() As Byte
Dim i As Integer
Dim crc As String
CrcHi = data(UBound(data))
CrcLo = data(UBound(data) - 1)
ReDim Checkdata(1 To (UBound(data) - 1)) As Byte
For i = 1 To (UBound(data) - 1) ‘附值
Checkdata(i) = data(i - 1)
Next
crc = Crc16(Checkdata)
If (CrcLo = Val("&H" & CStr(Mid(crc, 1, 2))) And CrcHi = Val("&H" & CStr(Mid(crc, 3, 2)))) Then
RtuCheck = 1
Else
RtuCheck = 0
End If
End Function