‘用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