frmutility.frm

ModBus通信测试工具,方便工程开发测试用.

     ProtSettings.Enabled = False
     cmdSend.Enabled = True
     SendData.Enabled = True
     lblPort.Caption = "端口打开"
     lblPort.ForeColor = &HC000&
  ElseIf cmdOpenCOM.Caption = "关闭通讯口(&C)" Then
     If MsCOM.PortOpen = True Then MsCOM.PortOpen = False
     cmdOpenCOM.Caption = "打开通讯口(&O)"
     ProtOpen.Caption = "打开端口"
     cmdComSet.Enabled = True
     ProtSettings.Enabled = True
     SendData.Enabled = False
     cmdSend.Enabled = False
     lblPort.Caption = "端口关闭"
     lblPort.ForeColor = vbRed
  End If
  Exit Sub
OpenErr:
  If Err.Number = 8002 Then
     MsgBox "端口号无效,系统找不到指定端口。", vbCritical
     Exit Sub
  ElseIf Err.Number = 8005 Then
     MsgBox "端口已被其它程序占用,请关闭程序或选择其它可用端口!", vbCritical
     Exit Sub
  Else
     MsgBox "系统打开端口出错!", vbExclamation
     Exit Sub
  End If
End Sub

Private Sub cmdSend_Click()
  Dim WriteBuf(7) As Byte, TemStr As String, i As Integer
  Dim ChangeStr As String, ChangeStrLen As Long, j As Long, Lencount As Long, ShowStr As String
  
  On Error Resume Next
  
  If SSTab.Tab = 0 Then
      If txtCommand.Text <> "03" And txtCommand.Text <> "06" Then
         MsgBox "ModBus通讯协议支持的功能码为：03、06，请重新输入。", vbCritical, "错误"
         Exit Sub
      End If
        
      WriteBuf(0) = Hex2Dec(txtMAddr)
      WriteBuf(1) = Hex2Dec(txtCommand)
      WriteBuf(2) = Hex2Dec(Left$(txtSAddr, 2))
      WriteBuf(3) = Hex2Dec(Right$(txtSAddr, 2))
      WriteBuf(4) = Hex2Dec(Left$(txtPSum, 2))
      WriteBuf(5) = Hex2Dec(Right$(txtPSum, 2))
      CRC16Lo = &HFF
      CRC16Hi = &HFF
      CRC16 WriteBuf(0)
      CRC16 WriteBuf(1)
      CRC16 WriteBuf(2)
      CRC16 WriteBuf(3)
      CRC16 WriteBuf(4)
      CRC16 WriteBuf(5)
      WriteBuf(6) = CRC16Lo  '取低位
      WriteBuf(7) = CRC16Hi  '取高位
      If Len(Hex(CRC16Lo)) > 1 And Len(Hex(CRC16Hi)) <= 1 Then
         txtCRC = Hex(CRC16Lo) & "0" & Hex(CRC16Hi)
      ElseIf Len(Hex(CRC16Lo)) <= 1 And Len(Hex(CRC16Hi)) > 1 Then
         txtCRC = "0" & Hex(CRC16Lo) & Hex(CRC16Hi)
      ElseIf Len(Hex(CRC16Lo)) <= 1 And Len(Hex(CRC16Hi)) <= 1 Then
         txtCRC = "0" & Hex(CRC16Lo) & "0" & Hex(CRC16Hi)
      ElseIf Len(Hex(CRC16Lo)) > 1 And Len(Hex(CRC16Hi)) > 1 Then
         txtCRC = Hex(CRC16Lo) & Hex(CRC16Hi)
      End If
      
      If CInt(txtCommand) = 3 Then                   '计算返回数长
         MsCOM.RThreshold = 5 + Hex2Dec(txtPSum) * 2
      ElseIf CInt(txtCommand) = 6 Then
         MsCOM.RThreshold = 8
      End If
      
      If MsCOM.PortOpen = True Then
         MsCOM.Output = WriteBuf
         For i = 0 To 7
            If WriteBuf(i) < 16 Then
               TemStr = TemStr & "0" & Hex(WriteBuf(i)) & Space(1)
            Else
               TemStr = TemStr & Hex(WriteBuf(i)) & Space(1)
            End If
         Next
         txtMData.Text = "TX:" & TemStr & Space(2) & "[" & Now() & "]" & vbCrLf & txtMData.Text
      Else
         MsgBox "通讯口未打开,请先打开通讯口再试!", vbExclamation
         Exit Sub
      End If
  ElseIf SSTab.Tab = 1 Then
      ChangeStr = Replace(txtData, " ", "", 1)
      ChangeStr = Replace(ChangeStr, vbCr, "", 1)
      ChangeStr = Replace(ChangeStr, vbLf, "", 1)
      
      ChangeStrLen = Len(ChangeStr) / 2 - 1
      
      ReDim SendBuf(ChangeStrLen)

      j = 1
      For i = 0 To ChangeStrLen - 2
          SendBuf(i) = Hex2Dec(Mid$(ChangeStr, j, 2))
          j = j + 2
      Next

      CRC16Lo = &HFF
      CRC16Hi = &HFF

      For i = 0 To ChangeStrLen - 2
        CRC16 SendBuf(i)
      Next

      SendBuf(ChangeStrLen - 1) = CRC16Lo '取低位
      SendBuf(ChangeStrLen) = CRC16Hi '取高位
      
      MsCOM.Output = SendBuf

      For i = 0 To ChangeStrLen
          Lencount = Len(Hex(SendBuf(i)))
          If Lencount > 1 Then
             ShowStr = ShowStr & Hex(SendBuf(i)) & Space(1)
          Else
             ShowStr = ShowStr & "0" & Hex(SendBuf(i)) & Space(1)
          End If
      Next i
      txtData = ShowStr
  End If
End Sub

Private Sub Content_Click()
  MsgBox "当前支持 [03]、[06] 两类ModBus功能码。", vbInformation
  Exit Sub
End Sub

Private Sub crc_Click()
  cmdCRC_Click
End Sub

Private Sub Form_Load()
  LoadOK = True
  xCOM = "1"
  ComSetting = "19200,N,8,1"
  lblComsettings = "COM:" & xCOM & Space(2) & "Settings：" & ComSetting
  MsCOM.RThreshold = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Cancel = True
  cmdExit_Click
End Sub

Private Sub MsCOM_OnComm()
  Dim InputData() As Byte, MData As String, HCommand As String, CRCcheck(2) As String
  Dim i As Long, Lencount As Long
  Dim InBufCount As Integer
  
  If MsCOM.CommEvent = 1 Then
     InBufCount = MsCOM.InBufferCount
  ElseIf MsCOM.CommEvent = comEvReceive Then
     InputData = Trim$(MsCOM.Input)
     For i = LBound(InputData) To UBound(InputData)
         Lencount = Len(Hex(InputData(i)))
         If Lencount > 1 Then
            MData = MData & Hex(InputData(i)) & Space(1)
            HCommand = HCommand & Hex(InputData(i))
         Else
            MData = MData & "0" & Hex(InputData(i)) & Space(1)
            HCommand = HCommand & "0" & Hex(InputData(i))
         End If
     Next i
'     校验
     CRC16Lo = &HFF
     CRC16Hi = &HFF
     
     For i = LBound(InputData) To UBound(InputData) - 2
         CRC16 InputData(i)
     Next
     
     If Len(Hex(CRC16Lo)) > 1 Then
        CRCcheck(0) = Hex(CRC16Lo)
     Else: CRCcheck(0) = "0" & Hex(CRC16Lo)
     End If
     
     If Len(Hex(CRC16Hi)) > 1 Then
        CRCcheck(1) = Hex(CRC16Hi)
     Else: CRCcheck(1) = "0" & Hex(CRC16Hi)
     End If
     
     CRCcheck(2) = CRCcheck(0) & CRCcheck(1)
'     校验正确
     If CRCcheck(2) = Right$(HCommand, 4) Then
         If SSTab.Tab = 0 Then
            txtMData = "RX:" & MData & Space(2) & "[" & Now & "]" & vbCrLf & txtMData
         ElseIf SSTab.Tab = 1 Then
            txtHCommand.Text = "Rx:" & MData & Space(2) & "[" & Now & "]" & vbCrLf & txtHCommand.Text
            If AutoSend = True Then
'            If AutoSend = True And HCommand = "0103200000330E1F" Then
'            If AutoSend = True And HCommand = "0103206000158FDB" Then
               txtMAddr = Left$(HCommand, 2): txtCommand = Mid$(HCommand, 3, 2): txtSAddr = Mid$(HCommand, 5, 4): txtPSum = Mid$(HCommand, 9, 4): txtCRC = Mid$(HCommand, 13, 4)
               SendDataPro (HCommand)
            End If
         End If
     End If
  End If
End Sub
Private Sub SendDataPro(RCommand As String)
  Dim Tem As Single, i As Integer, j As Integer, Lencount As Long, ShowStr As String, FunStr As String
  
  On Error Resume Next
  
'  确定发送寄存器个数及字节数大小
  FunStr = Mid$(RCommand, 3, 2)
  If FunStr = "03" Then
     ByteSize = Hex2Dec(Mid$(RCommand, 9, 4)) * 2
     ReDim SendBuf(ByteSize + 4) As Byte
    
     SendBuf(0) = Hex2Dec(Left$(RCommand, 2))
     SendBuf(1) = Hex2Dec(FunStr)
     SendBuf(2) = ByteSize
     
     If chkSetMax.Value = 1 Then
        For i = 3 To ByteSize + 2
            SendBuf(i) = &HFF
        Next
     End If
  ElseIf FunStr = "06" Then
     ByteSize = 8
     ReDim SendBuf(8) As Byte
    
     SendBuf(0) = Hex2Dec(Left$(RCommand, 2))
     SendBuf(1) = Hex2Dec(FunStr)
     SendBuf(2) = Hex2Dec(Mid$(RCommand, 5, 2))
     SendBuf(3) = Hex2Dec(Mid$(RCommand, 7, 2))
     SendBuf(4) = Hex2Dec(Mid$(RCommand, 9, 2))
     SendBuf(5) = Hex2Dec(Mid$(RCommand, 11, 2))
     SendBuf(6) = Hex2Dec(Mid$(RCommand, 13, 2))
     SendBuf(7) = Hex2Dec(Mid$(RCommand, 15, 2))
  End If
  
  CRC16Lo = &HFF
  CRC16Hi = &HFF
    
  For i = 0 To ByteSize + 2
      CRC16 SendBuf(i)
  Next
  
  SendBuf(ByteSize + 3) = CRC16Lo  '取低位
  SendBuf(ByteSize + 4) = CRC16Hi '取高位
  
  MsCOM.Output = SendBuf
  
 For i = 0 To ByteSize + 4
     Lencount = Len(Hex(SendBuf(i)))
     If Lencount > 1 Then
        ShowStr = ShowStr & Hex(SendBuf(i)) & Space(1)
     Else
        ShowStr = ShowStr & "0" & Hex(SendBuf(i)) & Space(1)
     End If
 Next i
 
 txtData.Text = ShowStr
  
End Sub
Private Sub ProtOpen_Click()
  cmdOpenCOM_Click
End Sub

Private Sub ProtSettings_Click()
  cmdComSet_Click
End Sub

Private Sub SendData_Click()
  cmdSend_Click
End Sub

Private Sub SSTab_Click(PreviousTab As Integer)
  Dim i As Integer
  If SSTab.Tab = 1 Then
     txtCommand = "03"
     txtSAddr = "0000"
     txtPSum = "0000"
     txtCRC = "45CA"
     txtCommand.Locked = True
     txtSAddr.Locked = True
     txtPSum.Locked = True
     txtMAddr.Locked = True
     cmdCRC.Enabled = False
     If cmdOpenCOM.Caption = "关闭通讯口(&C)" Then
        cmdSend.Enabled = True
        SendData.Enabled = True
     Else
        cmdSend.Enabled = False
        SendData.Enabled = False
     End If
     lblAddr.Caption = "响应地址："
     MsCOM.RThreshold = 8: ByteSize = 0
  ElseIf SSTab.Tab = 0 Then
     txtSAddr = "0000"
     txtPSum = "0000"
     txtCRC = "45CA"
     txtCommand.Locked = False
     txtSAddr.Locked = False
     txtPSum.Locked = False
     cmdCRC.Enabled = True
     If cmdOpenCOM.Caption = "关闭通讯口(&C)" Then
        cmdSend.Enabled = True
        SendData.Enabled = True
     Else
        cmdSend.Enabled = False
        SendData.Enabled = False
     End If
     lblAddr.Caption = "从机地址："
     chkAutoSend.Value = 0
     chkAutoSend_Click
     MsCOM.RThreshold = 0
  End If
End Sub
Private Sub TmFlash_Timer()
  If chkAutoSend.Value = 1 Then
     If lblMsg.Visible = True Then
        lblMsg.Visible = False
     Else: lblMsg.Visible = True
     End If
  Else: lblMsg.Visible = False
  End If
End Sub

Private Sub Toolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Key
    Case "ComSet"
      cmdComSet_Click
    Case "ProtOpen"
      cmdOpenCOM_Click
    Case "CRC"
      cmdCRC_Click
    Case "Send"
      cmdSend_Click
    Case "Clcer"
      cmdClcer_Click
    Case "Help"
      Content_Click
    Case "About"
      About_Click
    Case "Exit"
      cmdExit_Click
  End Select
End Sub