📄 frmcommtest.frm
字号:
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form FrmComTest
Caption = "通讯测试"
ClientHeight = 6780
ClientLeft = 60
ClientTop = 450
ClientWidth = 7455
LinkTopic = "Form1"
LockControls = -1 'True
MDIChild = -1 'True
ScaleHeight = 6780
ScaleWidth = 7455
Begin VB.Timer Timer1
Interval = 1
Left = 120
Top = 720
End
Begin VB.Frame Frame1
Caption = "端口设置"
Height = 690
Index = 0
Left = 210
TabIndex = 19
Top = 150
Width = 7050
Begin VB.ComboBox cboCommSettings
Height = 300
ItemData = "FrmCommTest.frx":0000
Left = 3195
List = "FrmCommTest.frx":001F
TabIndex = 23
Top = 240
Width = 1500
End
Begin VB.ComboBox cboCommPort
Height = 300
ItemData = "FrmCommTest.frx":0095
Left = 855
List = "FrmCommTest.frx":0097
Style = 2 'Dropdown List
TabIndex = 22
Top = 240
Width = 915
End
Begin VB.CommandButton cmdCommOpen
Caption = "打开(&O)"
Height = 330
Left = 4980
TabIndex = 21
Top = 225
Width = 900
End
Begin VB.CommandButton cmdClose
Caption = "关闭(&L)"
Height = 330
Left = 6000
TabIndex = 20
Top = 225
Width = 900
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "端口(&P):"
Height = 180
Index = 0
Left = 135
TabIndex = 25
Top = 300
Width = 720
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "数据格式(&F):"
Height = 180
Index = 1
Left = 2115
TabIndex = 24
Top = 300
Width = 1080
End
End
Begin VB.Frame Frame1
Caption = "发送"
Height = 1530
Index = 1
Left = 210
TabIndex = 8
Top = 900
Width = 7050
Begin VB.TextBox txtStart
Height = 270
Left = 1200
TabIndex = 15
ToolTipText = "十六进制"
Top = 210
Width = 900
End
Begin VB.TextBox txtEnd
Height = 270
Left = 4830
TabIndex = 14
ToolTipText = "十六进制"
Top = 210
Width = 900
End
Begin VB.CommandButton cmdSend
Caption = "发送(&S)"
Default = -1 'True
Enabled = 0 'False
Height = 330
Left = 6000
TabIndex = 13
Top = 180
Width = 900
End
Begin VB.OptionButton optCommData
Caption = "文本(&X)"
Height = 180
Index = 1
Left = 120
TabIndex = 12
Top = 1170
Width = 1035
End
Begin VB.OptionButton optCommData
Caption = "十六进制(&H)"
Height = 180
Index = 0
Left = 120
TabIndex = 11
Top = 900
Width = 1290
End
Begin VB.TextBox txtSend
Height = 810
Left = 1440
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 10
Top = 600
Width = 5475
End
Begin VB.CheckBox chkCheckSum
Caption = "校验和(&M)"
Height = 210
Left = 2400
TabIndex = 9
Top = 270
Width = 1200
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "前导标志(&R):"
Height = 180
Index = 5
Left = 120
TabIndex = 18
Top = 270
Width = 1080
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "结束标志(&E):"
Height = 180
Index = 6
Left = 3750
TabIndex = 17
Top = 270
Width = 1080
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "数据(&D):"
Height = 180
Index = 2
Left = 120
TabIndex = 16
Top = 600
Width = 720
End
End
Begin VB.Frame Frame1
Caption = "接收"
Height = 4125
Index = 2
Left = 210
TabIndex = 0
Top = 2460
Width = 7050
Begin VB.TextBox txtReceivedBinary
Height = 1785
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 5
TabStop = 0 'False
Top = 540
Width = 6795
End
Begin VB.TextBox txtReceivedText
Height = 1410
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 4
TabStop = 0 'False
Top = 2595
Width = 6795
End
Begin VB.CommandButton cmdClear
Caption = "清除(&C)"
Height = 330
Left = 6000
TabIndex = 3
Top = 180
Width = 900
End
Begin VB.CommandButton Cmd485
Caption = "485"
Height = 330
Index = 0
Left = 1410
TabIndex = 2
Top = 165
Width = 1005
End
Begin VB.CommandButton Cmd485
Caption = "CS"
Height = 330
Index = 1
Left = 2625
TabIndex = 1
Top = 165
Width = 1005
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "二进制信息:"
Height = 180
Index = 3
Left = 120
TabIndex = 7
Top = 300
Width = 990
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "文本信息:"
Height = 180
Index = 4
Left = 120
TabIndex = 6
Top = 2370
Width = 810
End
End
Begin MSCommLib.MSComm MSComm1
Left = 120
Top = 120
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
ParityReplace = 0
InputMode = 1
End
End
Attribute VB_Name = "FrmComTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Download by http://www.codefans.net
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub cboCommPort_Click()
CloseComm
End Sub
Private Sub cboCommSettings_Change()
CloseComm
End Sub
Private Sub cboCommSettings_Click()
CloseComm
End Sub
Private Sub chkCheckSum_Click()
chkCheckSum.ForeColor = IIf(chkCheckSum.Value = vbChecked, vbBlue, vbBlack)
End Sub
Private Sub Cmd485_Click(Index As Integer)
If Index = 0 Then
cboCommSettings = "1200,E,8,1"
txtSend.Text = "68 01 00 00 00 00 00 68 01 02 43 C3"
chkCheckSum.Value = vbChecked
txtEnd.Text = "16"
txtStart.Text = ""
optCommData(0).Value = True
Else
cboCommSettings = "300,E,7,1"
txtSend.Text = "2F 3F 21 D A"
chkCheckSum.Value = vbUnchecked
txtEnd.Text = ""
txtStart.Text = ""
optCommData(0).Value = True
End If
End Sub
Private Sub cmdClear_Click()
txtReceivedBinary.Text = ""
txtReceivedText.Text = ""
txtSend.SetFocus
End Sub
Private Sub cmdClose_Click()
CloseComm
End Sub
Private Sub cmdCommOpen_Click()
SetMP 11
CloseComm
On Error Resume Next
With MSComm1
.Commport = Val(Mid(cboCommPort.Text, 4))
.Settings = cboCommSettings.Text
.PortOpen = True
If Err = 0 Then
cmdSend.Enabled = True
Else
MsgBox "错误信息:" & vbCrLf & vbCrLf & Error & Space(7), vbInformation
End If
End With
SetMP 0
End Sub
Private Sub cmdSend_Click()
Dim arr() As Byte
Dim i As Long
Dim j As Long
Dim S As Long
Dim C As Long
Dim MSG(2) As String
SetMP 11
cmdSend.Enabled = False
On Error Resume Next
MSG(0) = txtStart.Text
MSG(1) = txtSend.Text
MSG(2) = txtEnd.Text
For i = 0 To 2
If i = 2 Then
If chkCheckSum.Value = vbChecked Then '数据字节校验和
C = C + 1
ReDim Preserve arr(C - 1)
arr(C - 1) = S Mod 256
End If
End If
If (i = 1) And optCommData(1).Value Then '文本方式
Do While Len(MSG(i)) > 0
C = C + 1
ReDim Preserve arr(C - 1)
arr(C - 1) = Asc(MSG(i))
If i = 1 Then S = S + arr(C - 1)
MSG(i) = Mid(MSG(i), 2)
Loop
Else '十六进制
MSG(i) = Trim(MSG(i))
Do While Len(MSG(i)) > 0
C = C + 1
ReDim Preserve arr(C - 1)
arr(C - 1) = Val("&H" & Left(MSG(i), 2))
If i = 1 Then S = S + arr(C - 1)
MSG(i) = Trim(Mid(MSG(i), 3))
Loop
End If
Next i
If C > 0 Then MSComm1.Output = arr()
If Err > 0 Then MsgBox "错误信息:" & vbCrLf & vbCrLf & Error & Space(7), vbInformation
txtSend.SetFocus
cmdSend.Enabled = True
SetMP 0
End Sub
Private Sub Form_Load()
Me.Top = 100
Me.Left = 100
Me.Width = 7575
Me.Height = 7290
Dim i As Integer
Dim MSG As String
Me.Enabled = False
MSG = "通讯测试"
cboCommSettings.Text = GetSetting(App.EXEName, "frmCommTest", "CommSettings", "2400,N,8,1")
Me.Show
Me.Refresh
With MSComm1
For i = 1 To 16
Me.Caption = MSG & " --- 测试通讯端口:COM" & i & "..."
Me.Refresh
Delay 100
On Error Resume Next
.Commport = i
.Settings = "2400,N,8,1"
.PortOpen = True
.PortOpen = False
If Err = 0 Then cboCommPort.AddItem "COM" & Trim(i)
Next i
End With
cboCommPort.ListIndex = 0
optCommData(0).Value = True
Me.Caption = MSG
Me.Refresh
If cboCommPort.ListCount = 0 Then MsgBox "程序检测不到可用的串行端口!"
Me.Enabled = True
End Sub
Private Sub SetMP(MP As Integer)
Me.MousePointer = MP
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Me.WindowState = vbNormal
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.EXEName, "frmCommTest", "CommSettings", cboCommSettings.Text
End Sub
Private Sub optCommData_Click(Index As Integer)
optCommData(0).ForeColor = IIf(optCommData(0).Value, &HFF0000, 0)
optCommData(1).ForeColor = IIf(optCommData(1).Value, &HFF0000, 0)
End Sub
Private Sub CloseComm()
On Error Resume Next
MSComm1.PortOpen = False
cmdSend.Enabled = False
End Sub
Private Sub Timer1_Timer()
Dim CommData As String
Dim i As Long
Dim Ch As Byte
Dim MsgB As String
Dim MsgT As String
Dim b(0) As Byte
If Not cmdSend.Enabled Then Exit Sub
On Error Resume Next
With MSComm1
If .InBufferCount > 0 Then
CommData = .Input
If LenB(CommData) > 0 Then
For i = 1 To LenB(CommData)
Ch = AscB(MidB(CommData, i, 1))
MsgB = MsgB & Right("0" & Hex(Ch), 2) & " "
MsgT = MsgT & Chr(Ch)
Next i
txtReceivedBinary.Text = txtReceivedBinary.Text & MsgB
txtReceivedText.Text = txtReceivedText.Text & MsgT
End If
End If
End With
If Err > 0 Then
MsgT = "错误信息:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & "您是否需要清除接收信息?"
If MsgBox(MsgT, vbQuestion + vbYesNo) = vbYes Then cmdClear_Click
End If
End Sub
Sub Delay(ByVal msValue As Long)
Dim EndTime As Long
EndTime = GetTickCount + msValue
Do
DoEvents
Loop Until GetTickCount >= EndTime
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -