实例介绍
【实例简介】本软件为调试时发送大量串口数据而写，考虑数据在Excel中编 辑比较方便，因此在普通串口调试功能基础上增加发送Excel中数据 的功能。 使用说明：Excel中第一列为序号，其内容可为序号或其他字符 、数字，如果为空其后数据不发送。同一行中数据依次发送，遇到单 元格为空时为止。 使用技巧：发送Excel中的数据提供发送范围选择、循环发送或 设定发送次数、设定发送间隔
【实例截图】
【核心代码】
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "mscomm32.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form ComAssist
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "串口调试助手"
ClientHeight = 7485
ClientLeft = 4020
ClientTop = 3120
ClientWidth = 10920
FillColor = &H0091CACA&
ForeColor = &H0091CACA&
Icon = "ComExcel.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 7485
ScaleWidth = 10920
Begin VB.CommandButton CmdStop
Caption = "停止发送"
Height = 280
Left = 9210
TabIndex = 59
Top = 6090
Width = 1605
End
Begin VB.TextBox TxtLine
Height = 300
Left = 1320
TabIndex = 57
Text = "1"
Top = 6080
Width = 540
End
Begin VB.CommandButton CmdHelp
Caption = "帮助"
Height = 300
Left = 9270
TabIndex = 55
Top = 7065
Width = 505
End
Begin VB.TextBox TxtGap
Height = 300
Left = 9780
TabIndex = 52
Text = "100"
Top = 6502
Width = 660
End
Begin VB.TextBox TxtTimes
Height = 300
Left = 8280
TabIndex = 50
Text = "1"
Top = 6502
Width = 540
End
Begin VB.CheckBox ChkExcelCycle
BackColor = &H0091CACA&
Caption = "Excel数据循环发送"
Height = 285
Left = 5370
TabIndex = 49
Top = 6510
Width = 1935
End
Begin VB.TextBox TxtTo
Height = 300
Left = 4000
TabIndex = 46
Text = "1000"
Top = 6502
Width = 870
End
Begin VB.TextBox TxtFrom
Height = 300
Left = 2310
TabIndex = 44
Text = "1"
Top = 6502
Width = 870
End
Begin VB.CheckBox ChkExcelRange
BackColor = &H0091CACA&
Caption = "Excel数据范围:"
Height = 285
Left = 30
TabIndex = 43
Top = 6540
Width = 1605
End
Begin VB.CommandButton CmdSelectExcel
Caption = "选择Excel"
Height = 280
Left = 2520
TabIndex = 42
Top = 6090
Width = 1225
End
Begin VB.TextBox TxtExcelPath
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 3795
TabIndex = 41
Text = "还没有选择Excel"
Top = 6090
Width = 3555
End
Begin VB.CommandButton CmdSendExcel
Caption = "发送Excel中数据"
Height = 280
Left = 7500
TabIndex = 40
Top = 6090
Width = 1605
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 8250
Top = 6930
_ExtentX = 847
_ExtentY = 847
_Version = 393216
Filter = "文本文件（*.txt）|*.txt"
End
Begin VB.Timer TmrAutoSend
Left = 7740
Top = 6960
End
Begin MSCommLib.MSComm MSComm
Left = 7050
Top = 6900
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
End
Begin VB.TextBox TxtAutoSendTime
Height = 300
Left = 1320
TabIndex = 38
Text = "1000"
Top = 5730
Width = 660
End
Begin VB.CommandButton CmdAmend
Appearance = 0 'Flat
Caption = "更改"
Height = 300
Left = 1250
TabIndex = 34
Top = 3480
Width = 505
End
Begin VB.CommandButton CmdSaveDisp
Appearance = 0 'Flat
Caption = "保存显示数据"
Height = 300
Left = 30
TabIndex = 33
Top = 3480
Width = 1225
End
Begin VB.CommandButton CmdQuit
Caption = "关闭程序"
Height = 495
Left = 9930
TabIndex = 20
Top = 6900
Width = 870
End
Begin VB.CommandButton CmdClearCounter
Caption = "计数清零"
Height = 300
Left = 6105
TabIndex = 19
Top = 7065
Width = 865
End
Begin VB.CommandButton CmdSendFile
Caption = "发送文件"
Height = 280
Left = 7500
TabIndex = 18
Top = 5740
Width = 1605
End
Begin VB.TextBox TxtSendPath
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 3800
TabIndex = 17
Text = "还没有选择文件"
Top = 5745
Width = 3555
End
Begin VB.CommandButton CmdSelectFile
Caption = "选择发送文件"
Height = 280
Left = 2520
TabIndex = 16
Top = 5740
Width = 1225
End
Begin VB.TextBox TxtTXCount
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 4680
TabIndex = 15
Text = "TX:0"
Top = 7065
Width = 1340
End
Begin VB.TextBox TxtRXCount
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 3345
TabIndex = 14
Text = "RX:0"
Top = 7065
Width = 1350
End
Begin VB.TextBox TxtStatus
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 255
TabIndex = 13
Top = 7065
Width = 3100
End
Begin VB.CheckBox ChkAutoSend
BackColor = &H0091CACA&
Caption = "Check4"
Height = 255
Left = 30
TabIndex = 12
Top = 5480
Width = 255
End
Begin VB.CheckBox ChkHexSend
BackColor = &H0091CACA&
Caption = "Check3"
Height = 255
Left = 30
TabIndex = 11
Top = 5160
Width = 255
End
Begin VB.CommandButton CmdSend
Caption = "手动发送"
Height = 300
Left = 1590
TabIndex = 10
Top = 5160
Width = 870
End
Begin VB.CommandButton CmdClearSend
Caption = "清空重填"
Height = 300
Left = 100
TabIndex = 9
Top = 4850
Width = 870
End
Begin VB.TextBox TxtSend
Height = 865
Left = 2560
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 8
Top = 4820
Width = 8225
End
Begin VB.TextBox TxtSavePath
BackColor = &H0091CACA&
Height = 270
Left = 60
TabIndex = 7
Text = "C:\COMDATA"
Top = 3795
Width = 1650
End
Begin VB.CheckBox ChkHexReceive
BackColor = &H0091CACA&
Caption = "十六进制显示"
Height = 255
Left = 45
TabIndex = 6
Top = 3195
Width = 1605
End
Begin VB.CheckBox ChkAutoClear
BackColor = &H0091CACA&
Caption = "自动清空"
Height = 255
Left = 45
TabIndex = 5
Top = 2940
Width = 1065
End
Begin VB.CommandButton CmdStopdisp
Caption = "停止显示"
Height = 310
Left = 30
TabIndex = 4
Top = 2610
Width = 1050
End
Begin VB.CommandButton CmdClearReceive
Caption = "清空接收区"
Height = 310
Left = 30
TabIndex = 3
Top = 2280
Width = 1050
End
Begin VB.Frame Frame1
BackColor = &H0091CACA&
Height = 2200
Left = 60
TabIndex = 2
Top = 0
Width = 1650
Begin VB.ComboBox CboStopbit
Height = 300
ItemData = "ComExcel.frx":000C
Left = 750
List = "ComExcel.frx":000E
TabIndex = 25
Text = "1"
Top = 1300
Width = 800
End
Begin VB.ComboBox CboDatabit
Height = 300
ItemData = "ComExcel.frx":0010
Left = 750
List = "ComExcel.frx":0012
TabIndex = 24
Text = "8"
Top = 1000
Width = 800
End
Begin VB.ComboBox CboParitybit
Height = 300
ItemData = "ComExcel.frx":0014
Left = 750
List = "ComExcel.frx":0016
TabIndex = 23
Text = "NONE"
Top = 700
Width = 800
End
Begin VB.ComboBox CboBaudrate
Height = 300
ItemData = "ComExcel.frx":0018
Left = 750
List = "ComExcel.frx":001A
TabIndex = 22
Text = "9600"
Top = 400
Width = 800
End
Begin VB.ComboBox CboCom
Height = 300
ItemData = "ComExcel.frx":001C
Left = 750
List = "ComExcel.frx":001E
TabIndex = 21
Text = "COM1"
Top = 111
Width = 800
End
Begin VB.CommandButton CmdSwitch
Caption = "关闭串口"
Height = 440
Left = 720
TabIndex = 1
Top = 1740
Width = 870
End
Begin VB.Image ImgSwitchOn
Appearance = 0 'Flat
Height = 420
Left = 120
Top = 1680
Width = 450
End
Begin VB.Image ImgSwitchOff
Height = 420
Left = 120
Top = 1680
Width = 450
End
Begin VB.Label Label8
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "停止位"
Height = 255
Left = 50
TabIndex = 32
Top = 1400
Width = 600
End
Begin VB.Label Label7
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "数据位"
Height = 255
Left = 50
TabIndex = 31
Top = 1080
Width = 600
End
Begin VB.Label Label6
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "校验位"
Height = 255
Left = 50
TabIndex = 30
Top = 760
Width = 600
End
Begin VB.Label Label5
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "波特率"
Height = 255
Left = 50
TabIndex = 29
Top = 470
Width = 600
End
Begin VB.Label Label4
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "串口"
Height = 255
Left = 50
TabIndex = 28
Top = 160
Width = 600
End
End
Begin VB.TextBox TxtReceive
Height = 4750
Left = 1800
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 0
Top = 6
Width = 8990
End
Begin VB.Label Label13
BackColor = &H0091CACA&
Caption = "Excel当前行:"
Height = 240
Left = 60
TabIndex = 58
Top = 6135
Width = 1110
End
Begin VB.Label LblWeb
BackColor = &H0091CACA&
Caption = "WEB"
ForeColor = &H008A7839&
Height = 225
Left = 8820
TabIndex = 56
Top = 17103
Visible = 0 'False
Width = 300
End
Begin VB.Label Label12
BackColor = &H0091CACA&
Caption = "发送间隔"
Height = 300
Left = 8970
TabIndex = 54
Top = 6540
Width = 810
End
Begin VB.Label Label10
BackColor = &H0091CACA&
Caption = "ms"
Height = 300
Left = 10590
TabIndex = 53
Top = 6540
Width = 270
End
Begin VB.Label Label9
BackColor = &H0091CACA&
Caption = "发送次数"
Height = 300
Left = 7365
TabIndex = 51
Top = 6540
Width = 810
End
Begin VB.Label Label3
BackColor = &H0091CACA&
Caption = "行"
Height = 300
Left = 4995
TabIndex = 48
Top = 6540
Width = 330
End
Begin VB.Label Label2
BackColor = &H0091CACA&
Caption = "行 To"
Height = 300
Left = 3330
TabIndex = 47
Top = 6540
Width = 570
End
Begin VB.Label Label1
BackColor = &H0091CACA&
Caption = "From"
Height = 300
Left = 1755
TabIndex = 45
Top = 6540
Width = 480
End
Begin VB.Label Label14
BackColor = &H0091CACA&
Caption = "毫秒"
Height = 255
Left = 2000
TabIndex = 39
Top = 5753
Width = 450
End
Begin VB.Label LblArtoSendCyc
BackColor = &H0091CACA&
Caption = "自动发送周期："
Height = 200
Left = 60
TabIndex = 37
Top = 5780
Width = 1270
End
Begin VB.Label LblAutoSend
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "自动发送(周期改变后重选)"
Height = 200
Left = 240
TabIndex = 36
Top = 5510
Width = 2215
End
Begin VB.Label Label11
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "十六进制发送"
Height = 200
Left = 240
TabIndex = 35
Top = 5200
Width = 1200
End
Begin VB.Label LblSend
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "发送的字符/数据"
Height = 270
Left = 1100
TabIndex = 27
Top = 4850
Width = 1420
End
Begin VB.Label LblReceive
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "接收区"
Height = 255
Left = 1125
TabIndex = 26
Top = 2265
Width = 600
End
End
Attribute VB_Name = "ComAssist"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'QQ:80420625
Option Explicit ' 强制显式声明
Dim ComSwitch As Boolean ' 串口开关状态判断
Dim FileData As String ' 要发送的文件暂存
Dim SendCount As Long ' 发送数据字节计数器
Dim ReceiveCount As Long ' 接收数据字节计数器
Dim InputSignal As String ' 接收缓冲暂存
Dim OutputSignal As String ' 发送数据暂存
Dim DisplaySwitch As Boolean ' 显示开关
Dim ModeSend As Boolean ' 发送方式判断
Dim Savetime As Single ' 时间数据暂存 延时用
Dim SaveTextPath As String ' 保存文本路径
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim SendArr() As Byte ' 发送数组
Dim bExcelRange As Boolean ' Excel数据范围
Dim bExcelCycle As Boolean ' Excel数据是否循环发送
Dim bExcelStop As Boolean
Dim nFrom As Long ' Excel数据发送开始行
Dim nTo As Long
Dim nExcelTimes As Long ' Excel数据发送循环次数
Dim nDelay As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub ChkExcelCycle_Click()
If ChkExcelCycle.Value = 1 Then
TxtTimes.Enabled = False
bExcelCycle = True
Else
TxtTimes.Enabled = True
TxtTimes = "0"
bExcelCycle = False
End If
End Sub
Private Sub ChkExcelRange_Click()
If ChkExcelRange.Value = 1 Then
TxtFrom.Enabled = True
TxtTo.Enabled = True
bExcelRange = True
Else
TxtFrom.Enabled = False
TxtTo.Enabled = False
bExcelRange = False
End If
End Sub
Private Sub CmdSelectExcel_Click()
Set xlApp = New Excel.Application
CommonDialog1.CancelError = True
On Error GoTo Errhandler
If Int(xlApp.Version) >= 12 Then
CommonDialog1.Filter = "Microsoft Excel (*.xlsx)|*.xlsx"
Else
CommonDialog1.Filter = "Microsoft Excel (*.xls)|*.xls"
End If
CommonDialog1.ShowOpen
TxtExcelPath.Text = CommonDialog1.FileName
Errhandler:
Set xlApp = Nothing
End Sub
Private Sub CmdSendExcel_Click()
Dim i%, j%, k%
Dim strSend As String
Dim nSendBytes&
Dim bCycle As Boolean
On Error GoTo ErrExcel
bExcelStop = False
If IsNumeric(TxtFrom) = False Then TxtFrom = "1"
If IsNumeric(TxtTo) = False Then TxtTo = "1"
If IsNumeric(TxtTimes) = False Then TxtTimes = "0"
If IsNumeric(TxtGap) = False Then TxtGap = "0"
nFrom = CLng(TxtFrom)
nTo = CLng(TxtTo)
nDelay = CLng(TxtGap)
nExcelTimes = CLng(TxtTimes)
If MSComm.PortOpen = True Then ' 如果串口打开了，则可以发送数据
If Dir(TxtExcelPath) = "" Then
MsgBox "请选择要发送数据的Excel路径!", vbInformation, "提示"
Exit Sub
End If
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Open(TxtExcelPath)
Set xlsheet = xlBook.Worksheets(1)
bCycle = IIf(nExcelTimes < 1 And bExcelCycle = False, False, True)
k = IIf(bExcelRange = True, nTo, xlsheet.Range("A1").End(xlDown).Row)
While bCycle
For i = IIf(bExcelRange = True, nFrom - 1, 0) To k - 1 '当选择范围时，从所选择开始行循环到所选择结束行
If xlsheet.Range("A1").Offset(i, 0) <> "" Then '第1列存序号，如果为空则表示该行没有数据。
TxtLine = i 1
j = 1
While xlsheet.Range("A1").Offset(i, j) <> "" '为空表示Cell中没有数据。
If bExcelStop = True Then
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
End If
strSend = xlsheet.Range("A1").Offset(i, j)
If ChkHexSend.Value = 1 Then ' 发送方式判断
nSendBytes = hexStr2bytes(Trim$(strSend))
MSComm.Output = SendArr ' 发送数据
SendCount = SendCount nSendBytes ' 计算总发送数
TxtTXCount.Text = "TX:" & SendCount
Else
MSComm.Output = Trim(strSend) ' 发送数据
SendCount = SendCount LenB(StrConv(strSend, vbFromUnicode)) ' 计算总发送数
TxtTXCount.Text = "TX:" & SendCount ' 发送字节数显示
End If
j = j 1
If nDelay > 0 Then
msDelay nDelay '延时nDelay毫秒
Else
DoEvents '可通过切换是否循环来停止发送
End If
Wend
End If
Next
If bExcelCycle = False Then nExcelTimes = nExcelTimes - 1
If nExcelTimes < 1 And bExcelCycle = False Then bCycle = False
If bExcelRange = True Then k = nTo '修改范围后立即生效
Wend
Else
MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提示打开串口
End If
xlBook.Close (True)
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlsheet = Nothing
Exit Sub
ErrExcel:
MsgBox Err.Number & vbCrLf & Err.Description
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Private Sub CmdStop_Click()
bExcelStop = True
End Sub
Private Sub Form_Load() ' 载入窗体
On Error GoTo Err
LblWeb.FontUnderline = True ' WEB上加下划线
LblWeb.ForeColor = vbBlue ' 蓝色显示WEB
ChkExcelCycle.Value = 0
ChkExcelRange.Value = 0
TxtFrom.Enabled = False
TxtTo.Enabled = False
TxtSend.Text = "http://www.csdn.net/" ' 载入发送信息
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
' 初始化串口
Call Comm_initial(Val(Mid(CboCom.Text, 4, 1)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text)
Err:
End Sub
Private Sub Comm_initial(Port As Byte, BaudRate As String, ParityBit As String, DataBit As Integer, StopBit As Integer)
On Error GoTo ErrorTrap ' 错误则跳往错误处理
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
MSComm.CommPort = Port ' 设定端口
MSComm.Settings = BaudRate & "," & ParityBit & "," & DataBit & "," & StopBit ' 设置波特率，无校验，8位数据位，1位停止位
MSComm.InBufferSize = 1024 ' 设置接收缓冲区为1024字节
MSComm.OutBufferSize = 4096 ' 设置发送缓冲区为4096字节
MSComm.RThreshold = 1 ' 每X个字符到接收缓冲区引起触发接收事件
MSComm.SThreshold = 1 ' 发送缓冲区空触发发送事件
MSComm.InBufferCount = 0 ' 清空接收缓冲区
MSComm.OutBufferCount = 0 ' 清空发送缓冲区
MSComm.InputLen = 0 ' 全部读空
' MSComm.InputMode = comInputModeBinary '以二进制取回
MSComm.PortOpen = True ' 打开串口
If MSComm.PortOpen = True Then
TxtStatus.Text = "STATUS：" & CboCom.Text & " OPEND，" & CboBaudrate.Text & "," & Left(CboParitybit.Text, 1) & "," & CboDatabit.Text & "," & CboStopbit.Text
Else
TxtStatus.Text = "STATUS：COM Port Cloced" ' 串口没打开时，提示串口关闭状态
End If
Exit Sub
ErrorTrap: ' 错误处理
Select Case Err.Number
Case comPortAlreadyOpen ' 如果串口已经打开，则提示
MsgBox "没有发现此串口或被占用", 49, "串口调试助手"
CloseCom
Case Else
MsgBox "没有发现此串口或被占用", 49, "串口调试助手"
CloseCom
End Select
Err.Clear
End Sub
Private Sub Comm_reSet(Port As Byte, BaudRate As String, ParityBit As String, DataBit As Integer, StopBit As Integer)
On Error GoTo ErrorHint ' 错误则跳往错误处理
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
MSComm.CommPort = Port ' 设定端口
MSComm.Settings = BaudRate & "," & ParityBit & "," & DataBit & "," & StopBit ' 设置波特率，无校验，8位数据位，1位停止位
MSComm.PortOpen = True ' 打开串口
If MSComm.PortOpen = True Then
CmdSwitch.Caption = "关闭串口"
ImgSwitchOn.Visible = True
ImgSwitchOff.Visible = False
TxtStatus.Text = "STATUS：" & CboCom.Text & " OPEND，" & CboBaudrate.Text & "," & Left(CboParitybit.Text, 1) & "," & CboDatabit.Text & "," & CboStopbit.Text
Else
CmdSwitch.Caption = "打开串口"
ImgSwitchOn.Visible = False
ImgSwitchOff.Visible = True
TxtStatus.Text = "STATUS：COM Port Cloced"
End If
Exit Sub
ErrorHint: ' 错误处理
Select Case Err.Number
Case comPortAlreadyOpen ' 如果串口已经打开，则提示
MsgBox "没有成功，请重试", vbExclamation, "串口调试助手"
CloseCom ' 调用关闭串口函数
Case Else
MsgBox "没有成功，请重试", vbExclamation, "串口调试助手"
CloseCom ' 调用关闭串口函数
End Select
Err.Clear ' 清除 Err 对象的属性
End Sub
Private Sub CmdSwitch_Click() ' 串口开关按钮
On Error GoTo Err
If MSComm.PortOpen = True Then
ComSwitch = True
Else
ComSwitch = False
End If
If ComSwitch = False Then
OpenCom ' 打开串口
ComSwitch = True
Else
CloseCom ' 关闭串口
ComSwitch = False
End If
Err:
End Sub
Private Sub OpenCom() '打开串口
On Error GoTo Err
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 1)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) ' 串口设置
If MSComm.PortOpen = True Then
TxtStatus.Text = "STATUS：" & CboCom.Text & " OPEND，" & CboBaudrate.Text & "," & Left(CboParitybit.Text, 1) & "," & CboDatabit.Text & "," & CboStopbit.Text
CmdSwitch.Caption = "关闭串口"
ImgSwitchOn.Visible = True ' 显示串口已经打开的图标
ImgSwitchOff.Visible = False
Else
TxtStatus.Text = "STATUS：COM Port Cloced" ' 串口状态显示
CmdSwitch.Caption = "打开串口"
ImgSwitchOff.Visible = True
ImgSwitchOn.Visible = False
End If
Err:
End Sub
Private Sub CloseCom() '关闭串口
On Error GoTo Err
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
TxtStatus.Text = "STATUS：COM Port Cloced" ' 串口状态显示
CmdSwitch.Caption = "打开串口"
ImgSwitchOn.Visible = False
ImgSwitchOff.Visible = True
Err:
End Sub
Private Sub ChkAutoSend_Click()
On Error GoTo Err
If ChkAutoSend.Value = 1 Then ' 如果有效则，自动发送
If MSComm.PortOpen = True Then ' 串口状态判断
TmrAutoSend.Interval = Val(TxtAutoSendTime) ' 设置自动发送时间
TmrAutoSend.Enabled = True ' 打开自动发送定时器
Else
ChkAutoSend.Value = 0 ' 串口没有打开去掉自动发送
MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提示打开串口
End If
ElseIf ChkAutoSend.Value = 0 Then ' 如果无效，不发送
TmrAutoSend.Enabled = False ' 关闭自动发送定时器
End If
Err:
End Sub
Private Sub LblWeb_Click() ' 单击打开网站
ShellExecute Me.hwnd, "open", "http://www.csdn.net/", "", "", 5 ' 要打开的网站
End Sub
Private Sub LblWeb_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' 鼠标移入 WEB 区
LblWeb.ForeColor = &H8A7839 ' 鼠标移入WEB时的颜色
LblWeb.MousePointer = 99 ' 鼠标移入WEB时的鼠标的现状 ,小手型
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) ' 鼠标移出 WEB 区
LblWeb.ForeColor = vbBlue ' 鼠标移出WEB时的颜色
Me.MousePointer = vbDefault ' 鼠标移出WEB时的鼠标的现状 即Me.MousePointer = 0
End Sub
Private Sub TmrAutoSend_Timer() ' 定时器
On Error GoTo Err
If TxtSend.Text = "" Then ' 判断发送数据是否为空
ChkAutoSend.Value = 0 ' 关闭自动发送
MsgBox "发送数据不能为空", 16, "串口调试助手" ' 发送数据为空则提示
Else
If ChkHexSend.Value = 1 Then ' 发送方式判断
MSComm.InputMode = comInputModeBinary ' 二进制发送
Call hexSend ' 发送十六进制数据
Else ' 按十六进制接收文本方式发送的数据时，文本也要按二进制发送发送
If ChkHexReceive.Value = 1 Then
MSComm.InputMode = comInputModeBinary ' 二进制发送
Else
MSComm.InputMode = comInputModeText ' 文本发送
End If
MSComm.Output = Trim(TxtSend.Text) ' 发送数据
ModeSend = False ' 设置文本发送方式
End If
End If
Err:
End Sub
Private Sub CmdSaveDisp_Click() ' 保存显示数据
On Error GoTo Err ' 错误处理
SaveTextPath = TxtSavePath ' 路径暂存
Open TxtSavePath & "\1.txt" For Output As #1 ' 打开文件
' 不存在的话 会创建文件,如已存在 会覆盖 output 改为append 为追加 改为input 则只读
Print #1, Year(Date) & "年" & Month(Date) & "月" & Day(Date) & _
"日" & Hour(Time) & "时" & Minute(Time) & "分" & Second(Time) & _
"秒" & vbCrLf & TxtReceive.Text vbCrLf ' 把接收区的文本保存 文本前加上保存时间 （0000年00月00日00时00分00秒）
Close #1 ' 关闭文件
TxtSavePath = "OK,1.txt Save" ' 提示保存成功
CmdSaveDisp.Enabled = False
Savetime = Timer ' 记下开始的时间
While Timer < Savetime 5 ' 循环等待 5 - 要延时的时间
DoEvents ' 转让控制权，以便让操作系统处理其它的事件。
Wend
TxtSavePath = SaveTextPath ' 显示保存路径
CmdSaveDisp.Enabled = True
Err:
End Sub
Private Sub CmdStopdisp_Click()
On Error GoTo Err
If DisplaySwitch = False Then
DisplaySwitch = True ' 关闭显示
CmdStopdisp.Caption = "继续显示"
Else
DisplaySwitch = False ' 开启显示
CmdStopdisp.Caption = "停止显示"
End If
Err:
End Sub
Private Sub CmdClearCounter_Click() ' 清除计数器
On Error GoTo Err
SendCount = 0 ' 发送计数器清零
ReceiveCount = 0 ' 接收计数器清零
TxtRXCount.Text = "RX:" & 0 ' 接收计数
TxtTXCount.Text = "TX:" & 0 ' 发送计数
Err:
End Sub
Private Sub CmdAmend_Click() '更改保存显示数据的目录
Dim spShell As Object ' 定义存放引用对象的变量
Dim spFolder As Object ' 定义存放引用对象的变量
Dim spFolderItem As Object ' 定义存放引用对象的变量
Dim spPath As String ' 定义存放的变量
On Error GoTo Err ' 错误处理，防止取消打开文件夹时报错
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Set spShell = CreateObject("Shell.Application")
Set spFolder = spShell.BrowseForFolder(WINDOW_HANDLE, "选择目录:", NO_OPTIONS, "C:\Scripts")
Set spFolderItem = spFolder.Self
spPath = spFolderItem.Path
spPath = Replace(spPath, "\", "\") ' Replace函数的返回值是一个字符串
TxtSavePath.Text = spPath ' 把文件夹路径显示在标签上
SaveTextPath = TxtSavePath.Text ' 路径暂存
Err:
End Sub
Private Sub CboBaudrate_Click() ' 修改波特率
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 2)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) '串口设置
End Sub
Private Sub CboCom_Click() ' 修改串口
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 2)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) '串口设置
End Sub
Private Sub CboDatabit_Click() ' 修改数据位
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 2)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) '串口设置
End Sub
Private Sub CboParitybit_Click() ' 修改校验位
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 2)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) '串口设置
End Sub
Private Sub CboStopbit_Click() ' 修改停止位
Call Comm_reSet(Val(Mid(CboCom.Text, 4, 2)), CboBaudrate.Text, Left(CboParitybit.Text, 1), CboDatabit.Text, CboStopbit.Text) '串口设置
End Sub
Private Sub CmdClearSend_Click() ' 清除发送区
TxtSend.Text = ""
End Sub
Private Sub CmdClearReceive_Click() ' 清空接收区
TxtReceive.Text = ""
End Sub
Private Sub CmdSelectFile_Click() ' 选择要发送的文件
On Error GoTo Err ' 错误处理
CommonDialog1.Flags = cdlCFBoth
CommonDialog1.ShowOpen
TxtSendPath.Text = CommonDialog1.FileName ' 把打开的文件名给于TxtSendPath
Open TxtSendPath.Text For Input As 1 ' 打开选择的文件
FileData = StrConv(InputB$(LOF(1), 1), vbUnicode) ' 显示打开的文件
Close 1 ' 关闭文件
Err:
End Sub
Private Sub CmdSendFile_Click() '发送文件
On Error GoTo Err
If MSComm.PortOpen = True Then ' 如果串口打开了，则可以发送数据
If FileData = "" Then ' 判断发送数据是否为空
MsgBox "发送的文件为空", 16, "串口调试助手" ' 发送数据为空则提示
Else
If ChkHexReceive.Value = 1 Then ' 如果按十六进制接收时，按二进制发送，否则按文本发送
MSComm.InputMode = comInputModeBinary ' 二进制发送
Else
MSComm.InputMode = comInputModeText ' 文本发送
End If
MSComm.Output = Trim(FileData) ' 发送数据
ModeSend = True ' 设置文本发送方式
End If
Else
MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提示打开串口
End If
Err:
End Sub
Private Sub CmdSend_Click() ' 发送按钮
On Error GoTo Err
If MSComm.PortOpen = True Then ' 如果串口打开了，则可以发送数据
If TxtSend.Text = "" Then ' 判断发送数据是否为空
MsgBox "发送数据不能为空", 16, "串口调试助手" ' 发送数据为空则提示
Else
If ChkHexSend.Value = 1 Then ' 发送方式判断
MSComm.InputMode = comInputModeBinary ' 二进制发送
Call hexSend ' 发送十六进制数据
Else ' 按十六进制接收文本方式发送的数据时，文本也要按二进制发送发送
If ChkHexReceive.Value = 1 Then
MSComm.InputMode = comInputModeBinary ' 二进制发送
Else
MSComm.InputMode = comInputModeText ' 文本发送
End If
MSComm.Output = Trim(TxtSend.Text) ' 发送数据
ModeSend = False ' 设置文本发送方式
End If
End If
Else
MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提示打开串口
End If
Err:
End Sub
Private Sub MSComm_OnComm() ' 设置oncomm事件，读取片机内存的值
On Error GoTo Err
Select Case MSComm.CommEvent ' 每接收1个数就触发一次
Case comEvReceive
If ChkHexReceive.Value = 1 Then
Call hexReceive ' 十六进制接收
Else
Call textReceive ' 文本接收
End If
Case comEvSend ' 每发送1个数就触发一次
If ChkHexSend.Value = 1 Then
Else
Call textSend ' 文本发送
End If
Case Else
End Select
Err:
End Sub
Private Sub hexReceive()
On Error GoTo Err
Dim ReceiveArr() As Byte ' 接收数据数组
Dim receiveData As String ' 数据暂存
Dim Counter As Integer ' 接收数据个数计数器
Dim i As Integer ' 循环变量
If (MSComm.InBufferCount > 0) Then
Counter = MSComm.InBufferCount ' 读取接收数据个数
receiveData = "" ' 清缓冲
MSComm.InputMode = comInputModeBinary
ReceiveArr = MSComm.Input ' 数据放入数组
For i = 0 To (Counter - 1) Step 1 ' 数据格式处理
If (ReceiveArr(i) < 16) Then
receiveData = receiveData & "0" Hex(ReceiveArr(i)) & Space(1) ' 小于16，前面加0
Else
receiveData = receiveData & Hex(ReceiveArr(i)) & Space(1) ' 加空格显示
End If
Next i
TxtReceive.Text = TxtReceive.Text receiveData ' 显示接收的十六进制数据
TxtReceive.SelStart = Len(TxtReceive.Text) ' 显示光标位置
End If
ReceiveCount = ReceiveCount Counter ' 接收计数
TxtRXCount.Text = "RX:" & ReceiveCount ' 接收字节数显示
If ChkAutoClear.Value = 1 Then ' 自动清空判断
If ReceiveCount >= 65535 Then
TxtReceive.Text = ""
End If
End If
Err:
End Sub
Private Sub textReceive()
On Error GoTo Err
MSComm.InputMode = comInputModeText
InputSignal = MSComm.Input
ReceiveCount = ReceiveCount LenB(StrConv(InputSignal, vbFromUnicode)) ' 计算总接收数据
If DisplaySwitch = False Then ' 显示接收文本
TxtReceive.Text = TxtReceive.Text & InputSignal ' 单片机内存的值用TextReceive显示出
TxtReceive.SelStart = Len(TxtReceive.Text) ' 显示光标位置
End If
TxtRXCount.Text = "RX:" & ReceiveCount ' 接收字节数显示
If ChkAutoClear.Value = 1 Then ' 自动清空判断
If ReceiveCount >= 65535 Then
TxtReceive.Text = ""
End If
End If
Err:
End Sub
Private Sub hexSend()
Dim nSendBytes&
nSendBytes = hexStr2bytes(Trim$(TxtSend))
MSComm.Output = SendArr ' 发送数据
SendCount = SendCount nSendBytes ' 计算总发送数
TxtTXCount.Text = "TX:" & SendCount
End Sub
Private Function hexStr2bytes(hexString As String) As Long
On Error Resume Next
Dim outputLen As Integer ' 发送数据长度
Dim outData As String ' 发送数据暂存
Dim TemporarySave As String ' 数据暂存
Dim dataCount As Integer ' 数据个数计数
Dim i As Integer ' 局部变量
outData = UCase(Replace(hexString, Space(1), Space(0))) ' 先去掉空格，再转换为大写字母
outData = UCase(outData) ' 转换成大写
outputLen = Len(outData) ' 数据长度
For i = 0 To outputLen
TemporarySave = Mid(outData, i 1, 1) ' 取一位数据
If (Asc(TemporarySave) >= 48 And Asc(TemporarySave) <= 57) Or (Asc(TemporarySave) >= 65 And Asc(TemporarySave) <= 70) Then
dataCount = dataCount 1
Else
Exit For
Exit Function
End If
Next
If dataCount Mod 2 <> 0 Then ' 判断十六进制数据是否为双数
dataCount = dataCount - 1 ' 不是双数，则减1
End If
outData = Left(outData, dataCount) ' 取出有效的十六进制数据
dataCount = dataCount / 2
ReDim SendArr(dataCount - 1) ' 重新定义数组长度
For i = 0 To dataCount - 1
SendArr(i) = Val("&H" Mid(outData, i * 2 1, 2)) ' 取出数据转换成十六进制并放入数组中
Next
hexStr2bytes = dataCount ' 计算发送数
End Function
Private Sub textSend()
On Error GoTo Err
If ModeSend = True Then
OutputSignal = FileData ' 发送文件
Else
OutputSignal = TxtSend.Text ' 发送文本
End If
SendCount = SendCount LenB(StrConv(OutputSignal, vbFromUnicode)) ' 计算总发送数
TxtTXCount.Text = "TX:" & SendCount ' 发送字节数显示
Err:
End Sub
Private Sub CmdQuit_Click() ' 退出程序
If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打开，如果打开则先关闭
Unload Me ' 卸载窗体，并退出程序
End
End Sub
Private Sub CmdHelp_Click() ' 载入帮助信息窗口
FrmHelp.Show
End Sub
Private Sub TxtGap_Change()
If IsNumeric(TxtGap) Then nDelay = CLng(TxtGap)
End Sub
Private Sub Txtfrom_Change()
If IsNumeric(TxtFrom) Then nFrom = CLng(TxtFrom)
End Sub
Private Sub TxtTo_Change()
If IsNumeric(TxtTo) Then nTo = CLng(TxtTo)
End Sub
Private Sub TxtTimes_Change()
If IsNumeric(TxtTimes) Then nExcelTimes = CLng(TxtTimes)
End Sub
好例子网口号：伸出你的我的手 — 分享！
小贴士
感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论