www.pudn.com > ModBusUtility.rar > frmUtility.frm
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmUtility
Caption = "ModBus Utility (Ver 1.0.0)"
ClientHeight = 7515
ClientLeft = 60
ClientTop = 750
ClientWidth = 10095
Icon = "frmUtility.frx":0000
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 7515
ScaleWidth = 10095
StartUpPosition = 2 '屏幕中心
Begin MSCommLib.MSComm MsCOM
Left = 9045
Top = 0
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
BaudRate = 19200
SThreshold = 2
InputMode = 1
End
Begin MSComctlLib.ImageList ImageList
Left = 9600
Top = -120
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 8
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":0E42
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":2B4C
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":399E
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":47F0
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":64FA
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":734C
Key = ""
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":7666
Key = ""
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmUtility.frx":84B8
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.Toolbar Toolbar
Align = 1 'Align Top
Height = 360
Left = 0
TabIndex = 23
Top = 0
Width = 10095
_ExtentX = 17806
_ExtentY = 635
ButtonWidth = 609
ButtonHeight = 582
Style = 1
ImageList = "ImageList"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 11
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "ComSet"
Object.ToolTipText = "端口设置"
ImageIndex = 5
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Style = 3
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "ProtOpen"
Object.ToolTipText = "打开端口"
ImageIndex = 2
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "CRC"
Object.ToolTipText = "CRC测试"
ImageIndex = 6
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Send"
Object.ToolTipText = "发送数据"
ImageIndex = 7
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Clcer"
Object.ToolTipText = "清空接收区"
ImageIndex = 1
EndProperty
BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628}
Style = 3
EndProperty
BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Help"
Object.ToolTipText = "Online Help"
ImageIndex = 4
EndProperty
BeginProperty Button9 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "About"
Object.ToolTipText = "About CH2000M Utility"
ImageIndex = 3
EndProperty
BeginProperty Button10 {66833FEA-8583-11D1-B16A-00C0F0283628}
Style = 3
EndProperty
BeginProperty Button11 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Exit"
Object.ToolTipText = "退出"
ImageIndex = 8
EndProperty
EndProperty
BorderStyle = 1
Begin VB.Timer TmFlash
Enabled = 0 'False
Interval = 500
Left = 8610
Top = -30
End
End
Begin VB.CommandButton cmdExit
Caption = "退 出(E)"
Height = 615
Left = 8370
TabIndex = 5
Top = 6510
Width = 1545
End
Begin VB.CommandButton cmdClcer
Caption = "清空接收区(&C)"
Height = 615
Left = 6750
TabIndex = 4
Top = 6510
Width = 1620
End
Begin VB.CommandButton cmdSend
Caption = "发送数据(&S)"
Enabled = 0 'False
Height = 615
Left = 5130
TabIndex = 3
Top = 6510
Width = 1620
End
Begin VB.CommandButton cmdCRC
Caption = "CRC测试(&T)"
Height = 615
Left = 3510
TabIndex = 2
Top = 6510
Width = 1620
End
Begin VB.CommandButton cmdOpenCOM
Caption = "打开通讯口(&O)"
Height = 615
Left = 1890
TabIndex = 1
Top = 6510
Width = 1620
End
Begin VB.CommandButton cmdComSet
Caption = "通讯口设置(&P)"
Height = 615
Left = 270
TabIndex = 0
Top = 6510
Width = 1620
End
Begin VB.TextBox txtCRC
Alignment = 2 'Center
Height = 270
Left = 8940
Locked = -1 'True
TabIndex = 13
Text = "45CA"
Top = 6150
Width = 630
End
Begin VB.TextBox txtPSum
Alignment = 2 'Center
Height = 270
Left = 7290
MaxLength = 4
TabIndex = 12
Text = "0000"
Top = 6150
Width = 630
End
Begin VB.TextBox txtSAddr
Alignment = 2 'Center
Height = 270
Left = 5280
MaxLength = 4
TabIndex = 11
Text = "0000"
Top = 6150
Width = 630
End
Begin VB.TextBox txtCommand
Alignment = 2 'Center
Height = 270
Left = 3270
MaxLength = 2
TabIndex = 10
Text = "03"
Top = 6150
Width = 630
End
Begin VB.TextBox txtMAddr
Alignment = 2 'Center
Height = 270
Left = 1425
MaxLength = 2
TabIndex = 9
Text = "01"
Top = 6150
Width = 630
End
Begin TabDlg.SSTab SSTab
Height = 5025
Left = 255
TabIndex = 6
Top = 1035
Width = 9660
_ExtentX = 17039
_ExtentY = 8864
_Version = 393216
Tabs = 2
TabsPerRow = 2
TabHeight = 520
ForeColor = 16711680
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
TabCaption(0) = "主机发送"
TabPicture(0) = "frmUtility.frx":930A
Tab(0).ControlEnabled= -1 'True
Tab(0).Control(0)= "Frame(1)"
Tab(0).Control(0).Enabled= 0 'False
Tab(0).ControlCount= 1
TabCaption(1) = "从机响应"
TabPicture(1) = "frmUtility.frx":9326
Tab(1).ControlEnabled= 0 'False
Tab(1).Control(0)= "lblMsg"
Tab(1).Control(0).Enabled= 0 'False
Tab(1).Control(1)= "Frame(2)"
Tab(1).Control(1).Enabled= 0 'False
Tab(1).Control(2)= "chkAutoSend"
Tab(1).Control(2).Enabled= 0 'False
Tab(1).Control(3)= "chkSetMax"
Tab(1).Control(3).Enabled= 0 'False
Tab(1).ControlCount= 4
Begin VB.CheckBox chkSetMax
Caption = "置最大值"
ForeColor = &H00808000&
Height = 180
Left = -66795
TabIndex = 31
Top = 150
Width = 1020
End
Begin VB.CheckBox chkAutoSend
Caption = "自动响应"
ForeColor = &H000040C0&
Height = 180
Left = -69645
TabIndex = 26
Top = 150
Width = 1020
End
Begin VB.Frame Frame
Caption = "响应数据"
Height = 4560
Index = 2
Left = -74880
TabIndex = 21
Top = 345
Width = 9420
Begin VB.TextBox txtHCommand
Height = 1335
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 28
Top = 3165
Width = 9285
End
Begin VB.TextBox txtData
Height = 2820
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 25
Top = 330
Width = 9285
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33"
ForeColor = &H00C000C0&
Height = 165
Left = 105
TabIndex = 30
Top = 165
Width = 8820
End
End
Begin VB.Frame Frame
Caption = "数据"
Height = 4560
Index = 1
Left = 120
TabIndex = 19
Top = 345
Width = 9420
Begin VB.TextBox txtMData
Appearance = 0 'Flat
BackColor = &H8000000F&
BorderStyle = 0 'None
Height = 4320
Left = 30
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 20
TabStop = 0 'False
Top = 195
Width = 9345
End
End
Begin VB.Label lblMsg
BackStyle = 0 'Transparent
Caption = "→ → →"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 195
Left = -68205
TabIndex = 29
Top = 210
Visible = 0 'False
Width = 945
End
End
Begin VB.Label lblPort
Caption = "端口关闭"
ForeColor = &H000000FF&
Height = 165
Left = 3360
TabIndex = 27
Top = 7245
Width = 720
End
Begin VB.Label Label
Alignment = 2 'Center
Caption = "ModBus 通 讯 测 试"
BeginProperty Font
Name = "楷体_GB2312"
Size = 21.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 0
Left = 2130
TabIndex = 24
Top = 450
Width = 6000
End
Begin VB.Label lblComsettings
BackColor = &H008080FF&
BackStyle = 0 'Transparent
Caption = "COM:1 Settings:19200,n,8,1"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 240
Left = 270
TabIndex = 22
Top = 7200
Width = 4875
End
Begin VB.Label Label5
Alignment = 2 'Center
Caption = "CRC码："
ForeColor = &H00FF0000&
Height = 210
Left = 8340
TabIndex = 18
Top = 6195
Width = 705
End
Begin VB.Label Label4
Alignment = 2 'Center
Caption = "点数/数据："
ForeColor = &H00FF0000&
Height = 210
Left = 6360
TabIndex = 17
Top = 6195
Width = 1005
End
Begin VB.Label Label3
Alignment = 2 'Center
Caption = "起始地址："
ForeColor = &H00FF0000&
Height = 210
Left = 4425
TabIndex = 16
Top = 6195
Width = 945
End
Begin VB.Label Label2
Alignment = 2 'Center
Caption = "功能码："
ForeColor = &H00FF0000&
Height = 210
Left = 2505
TabIndex = 15
Top = 6195
Width = 945
End
Begin VB.Label lblAddr
Alignment = 2 'Center
Caption = "从机地址："
ForeColor = &H00FF0000&
Height = 210
Left = 570
TabIndex = 14
Top = 6195
Width = 945
End
Begin VB.Label Label
Alignment = 2 'Center
BackColor = &H00FF8080&
BackStyle = 0 'Transparent
Caption = "Copyright (C) 2004 C.Y.Huang"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00808080&
Height = 255
Index = 39
Left = 4890
TabIndex = 8
Top = 7200
Width = 3435
End
Begin VB.Label Label
BorderStyle = 1 'Fixed Single
Height = 6120
Index = 1
Left = 240
TabIndex = 7
Top = 1020
Width = 9690
End
Begin VB.Menu Oper
Caption = "设置(&S)"
Begin VB.Menu ProtSettings
Caption = "端口设置(&P)"
End
Begin VB.Menu N1
Caption = "-"
End
Begin VB.Menu Close
Caption = "退 出(&C)"
End
End
Begin VB.Menu Cor
Caption = "通信(&C)"
Begin VB.Menu ProtOpen
Caption = "打开端口(&O)"
End
Begin VB.Menu N3
Caption = "-"
End
Begin VB.Menu crc
Caption = "CRC测试(&T)"
End
Begin VB.Menu SendData
Caption = "发送数据(&S)"
Enabled = 0 'False
End
Begin VB.Menu N5
Caption = "-"
End
Begin VB.Menu Clcer
Caption = "清空接收区(&C)"
End
End
Begin VB.Menu Help
Caption = "帮助(&H)"
Begin VB.Menu Content
Caption = "Content(&C)"
End
Begin VB.Menu N4
Caption = "-"
End
Begin VB.Menu About
Caption = "About ModBus Utility(&A)"
End
End
End
Attribute VB_Name = "frmUtility"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim CRC16Lo As Byte, CRC16Hi As Byte 'CRC寄存器
Dim LoadOK As Boolean, AutoSend As Boolean
Dim SendBuf() As Byte, ByteSize As Long
Dim SetMax As Boolean
Private Sub CRC16(data As Byte)
Dim CL As Byte, CH As Byte '多项式码&HA001
Dim SaveHi As Byte, SaveLo As Byte
Dim i As Integer
CL = &H1
CH = &HA0
CRC16Lo = CRC16Lo Xor data '每一个数据与CRC寄存器低位进行异或
For i = 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 '如果右移前低位字节最后一位为1，则与多项式码进行异或
CRC16Hi = CRC16Hi Xor CH
CRC16Lo = CRC16Lo Xor CL
End If
Next i
End Sub
Private Sub About_Click()
frmAbout.Show
End Sub
Private Sub chkAutoSend_Click()
If chkAutoSend.Value = 1 Then
AutoSend = True
TmFlash.Enabled = True
cmdSend.Enabled = False
ElseIf chkAutoSend.Value = 0 Then
AutoSend = False
TmFlash.Enabled = False
lblMsg.Visible = False
txtMAddr = "01": txtCommand = "03": txtSAddr = "0000": txtPSum = "0000": txtCRC = "45CA"
cmdSend.Enabled = True
End If
End Sub
Private Sub chkSetMax_Click()
If chkSetMax.Value = 1 Then
SetMax = True
Else: SetMax = False
End If
End Sub
Private Sub Clcer_Click()
cmdClcer_Click
End Sub
Private Sub Close_Click()
cmdExit_Click
End Sub
Private Sub cmdClcer_Click()
Dim InBufCount As Integer
If SSTab.Tab = 0 Then
InBufCount = MsCOM.InBufferCount
txtMData = ""
ElseIf SSTab.Tab = 1 Then
txtHCommand = ""
InBufCount = MsCOM.InBufferCount
End If
End Sub
Private Sub cmdComSet_Click()
frmCOM.Show
frmCOMopen = True
End Sub
Private Sub cmdCRC_Click()
Dim WriteBuf(7) As Byte, Tem As Single
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 '取高位
' txtMData = ""
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
End Sub
Private Sub cmdExit_Click()
If MsgBox("你真的退出吗?", vbYesNo + vbQuestion, "确认") = vbYes Then
LoadOK = False
If MsCOM.PortOpen = True Then MsCOM.PortOpen = False
MsCOM.InBufferCount = 0
If frmCOMopen = True Then Unload frmCOM
Set frmUtility = Nothing
End
Unload Me
End If
End Sub
Private Sub cmdOpenCOM_Click()
On Error GoTo OpenErr:
If cmdOpenCOM.Caption = "打开通讯口(&O)" Then
MsCOM.CommPort = xCOM
MsCOM.Settings = ComSetting
If MsCOM.PortOpen = False Then MsCOM.PortOpen = True
cmdOpenCOM.Caption = "关闭通讯口(&C)"
ProtOpen.Caption = "关闭端口"
cmdComSet.Enabled = False
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