经典的串口调试助手源代码

1、 Dim OutputAscii As BooleanDim InputString As StringDim OutputString As String'= =' 变量定义'= =Option Explicit ' 强制显式声明Dim ComSwitch As Boolean ' 串口开关状态判断Dim FileData As String ' 要发送的文件暂存Dim SendCount As Long ' 发送数据字节计数器Dim ReceiveCount As Long ' 接收数据字节计数器Dim InputSignal

2、 As String ' 接收缓冲暂存Dim OutputSignal As String ' 发送数据暂存Dim DisplaySwitch As Boolean ' 显示开关Dim ModeSend As Boolean ' 发送方式判断Dim Savetime As Single ' 时间数据暂存 延时用Dim SaveTextPath As String ' 保存文本路径' 网页超链接申明Private Declare Function ShellExecute Lib "shell32.dll" Alias

3、"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 LongPrivate Sub CloseCom( ' 关闭串口On Error GoTo ErrIf MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先

4、判断串口是否打 开,如果打开则先关闭txtstatus.Text = "STATUS:COM Port Cloced" ' 串口状态显示mnuconnect.Caption = "断开串口 "cmdswitch.Caption = "打开串口 "'ImgSwitch.Picture = LoadPicture("f:我的 VB串口调试软件 图片 guan.jpg" ' 显示串口已经关闭 的图标ImgSwitchoff.Visible = TrueImgSwitchon.Visible = F

5、alseErr:End SubPrivate Sub UpdateStatus(If MSComm.PortOpen ThenStatusBar1.Panels(1.Text = "Connected"mnuautosend.Caption = "自动发送 "mnuconnect.Caption = "断开串口 "ElseStatusBar1.Panels(1.Text = "断开串口 "mnuautosend.Caption = "disautosend"mnuconnect.Caption

6、= "打开串口 "End IfStatusBar1.Panels(2.Text = "COM" & MSComm.CommPortStatusBar1.Panels(3.Text = MSComm.SettingsIf (OutputAscii ThenStatusBar1.Panels(4 = "ASCII"ElseStatusBar1.Panels(4 = "HEX"End If'On Error GoTo ErrIf ChkAutoSend.Value = 1 Then ' 如果有效则

7、,自动发送If MSComm.PortOpen = True Then ' 串口状态判断mnuautosend.Caption = "Dis&autosend"TmrAutoSend.Interval = Val(TxtAutoSendTime ' 设置自动发送时间TmrAutoSend.Enabled = True ' 打开自动发送定时器Elsemnuautosend.Caption = "autosend"ChkAutoSend.Value = 0 ' 串口没有打开去掉自动发送MsgBox "串口没有

8、打开,请打开串口 ", 48, "串口调试助手 " ' 如果串口没有被打开,提 示打开串口End IfElseIf ChkAutoSend.Value = 0 Then ' 如果无效,不发送mnuautosend.Caption = "autosend"TmrAutoSend.Enabled = False ' 关闭自动发送定时器End IfErr:End SubPrivate Sub CmdSendFile_Click( '发送文件On Error GoTo ErrIf MSComm.PortOpen = Tr

9、ue Then ' 如果串口打开了,则可以发送数 据If FileData = "" Then ' 判断发送数据是否为空MsgBox "发送的文件为空 ", 16, "串口调试助手 " ' 发送数据为空则提示ElseIf ChkHexReceive.Value = 1 Then ' 如果按十六进制接收时,按二进制 发送,否则按文本发送MSComm.InputMode = comInputModeBinary ' 二进制发送ElseMSComm.InputMode = comInputModeTe

10、xt ' 文本发送End IfMSComm.Output = Trim(FileData ' 发送数据ModeSend = True ' 设置文本发送方式End IfElseMsgBox "串口没有打开,请打开串口 ", 48, "串口调试助手 " ' 如果串口没有被打开,提 示打开串口End IfErr:End SubPrivate Sub Comm_initial(Port As Byte, BaudRate As String, ParityBit As String, DataBit As Integer, Sto

11、pBit As IntegerOn Error GoTo ErrorTrap ' 错误则跳往错误处理If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打 开,如果打开则先关闭MSComm.CommPort = Port ' 设定端口MSComm.Settings = BaudRate & "," & ParityBit & "," & DataBit & "," & StopBit &#

12、39; 设置波特率,无校 验, 8位数据位, 1位停止位MSComm.InBufferSize = 1024 ' 设置接收缓冲区为 1024字节 MSComm.OutBufferSize = 4096 ' 设置发送缓冲区为 4096字节 MSComm.InBufferCount = 0 ' 清空输入缓冲区MSComm.OutBufferCount = 0 ' 清空输出缓冲区MSComm.SThreshold = 1 ' 发送缓冲区空触发发送事件MSComm.RThreshold = 1 ' 每 X 个字符到接收缓冲区引起触发接 收事件MSComm

13、.OutBufferCount = 0 ' 清空发送缓冲区MSComm.InBufferCount = 0 ' 滑空接收缓冲MSComm.PortOpen = True ' 打开串口If MSComm.PortOpen = True Thentxtstatus.Text = "STATUS :" & cbocom.Text & " OPEND , " & cbobaudrate.Text & "," & Left(cboparitybit.Text, 1 & &q

14、uot;," & cbodatabit.Text & "," & cbostopbit.TextElsetxtstatus.Text = "STATUS:COM Port Cloced" ' 串口没打开时,提示串口关闭 状态End IfExit SubErrorTrap: ' 错误处理Select Case Err.NumberCase comPortAlreadyOpen ' 如果串口已经打开,则提示MsgBox "没有发现此串口或被占用 ", 49, "串口调试助

15、手 "CloseComCase ElseMsgBox "没有发现此串口或被占用 ", 49, "串口调试助手 "CloseComEnd SelectErr.ClearEnd SubPrivate Sub Comm_reSet(Port As Byte, BaudRate As String, ParityBit As String, DataBit As Integer,StopBit As IntegerOn Error GoTo ErrorHint ' 错误则跳往错误处理If MSComm.PortOpen = True Then

16、MSComm.PortOpen = False ' 先判断串口是否打 开,如果打开则先关闭MSComm.CommPort = Port ' 设定端口MSComm.Settings = BaudRate & "," & ParityBit & "," & DataBit & "," & StopBit ' 设置波特率,无校 验, 8位数据位, 1位停止位MSComm.PortOpen = True ' 打开串口If MSComm.PortOpen = Tru

17、e Thencmdswitch.Caption = "关闭串口 "'ImgSwitch.Picture = LoadPicture("f:我的 VB串口调试软件 图片 kai.jpg" ' 显示串口已经打开的 图标ImgSwitchoff.Visible = Falsemnuconnect.Caption = "disconnect"ImgSwitchon.Visible = Truetxtstatus.Text = "STATUS :" & cbocom.Text & "

18、 OPEND , " & cbobaudrate.Text & "," & Left(cboparitybit.Text, 1 & "," & cbodatabit.Text & "," & cbostopbit.TextElsecmdswitch.Caption = "打开串口 "'ImgSwitch.Picture = LoadPicture("f:我的 VB串口调试软件 图片 guan.jpg" ' 显示串口

19、已经关闭 的图标ImgSwitchon.Visible = FalseImgSwitchoff.Visible = Truetxtstatus.Text = "STATUS:COM Port Cloced"End IfExit SubErrorHint: ' 错误处理Select Case Err.NumberCase comPortAlreadyOpen ' 如果串口已经打开,则提示MsgBox "没有成功,请重试 ", vbExclamation, "串口调试助手 "CloseCom ' 调用关闭串口函数C

20、ase ElseMsgBox "没有成功,请重试 ", vbExclamation, "串口调试助手 "CloseCom ' 调用关闭串口函数End SelectErr.Clear ' 清除 Err 对象的属性End SubPrivate Sub Command1_Click(End SubPrivate Sub cbobaudrate_Change(Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2, cbobaudrate.Text, Left(cboparitybit.Text, 1, cbodata

21、bit.Text, cbostopbit.Text ' 串口设置End SubPrivate Sub cbocom_Change(Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2, cbobaudrate.Text, Left(cboparitybit.Text, 1, cbodatabit.Text, cbostopbit.Text ' 串口设置End SubPrivate Sub cbodatabit_Change(Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2, cbobaudrate.Text, Le

22、ft(cboparitybit.Text, 1, cbodatabit.Text, cbostopbit.Text ' 串口设置End SubPrivate Sub cboparitybit_Change(Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2, cbobaudrate.Text, Left(cboparitybit.Text, 1, cbodatabit.Text, cbostopbit.Text ' 串口设置End SubPrivate Sub cbostopbit_Change(Call Comm_reSet(Val(Mid(c

23、bocom.Text, 4, 2, cbobaudrate.Text, Left(cboparitybit.Text, 1, cbodatabit.Text, cbostopbit.Text ' 串口设置End SubPrivate Sub chkautosend_Click(On Error GoTo ErrIf ChkAutoSend.Value = 1 Then ' 如果有效则,自动发送If MSComm.PortOpen = True Then ' 串口状态判断mnuautosend.Caption = "取消自动发送 "TmrAutoSen

24、d.Interval = Val(TxtAutoSendTime ' 设置自动发送时间TmrAutoSend.Enabled = True ' 打开自动发送定时器ElseChkAutoSend.Value = 0 ' 串口没有打开去掉自动发送MsgBox "串口没有打开,请打开串口 ", 48, "串口调试助手 " ' 如果串口没有被打开,提 示打开串口End IfElseIf ChkAutoSend.Value = 0 Then ' 如果无效,不发送mnuautosend.Caption = "自动发送

25、数据 "TmrAutoSend.Enabled = False ' 关闭自动发送定时器End IfErr:End SubPrivate Sub cmdamend_Click(Dim spShell As Object ' 定义存放引用对象的变量Dim spFolder As Object ' 定义存放引用对象的变量Dim spFolderItem As Object ' 定义存放引用对象的变量Dim spPath As String ' 定义存放的变量On Error GoTo Err ' 错误处理,防止取消打开文件夹时报错 Const

26、 WINDOW_HANDLE = 0Const NO_OPTIONS = 0Set spShell = CreateObject("Shell.Application"Set spFolder = spShell.BrowseForFolder(WINDOW_HANDLE, " 选 择 目 录 :", NO_OPTIONS, "C:Scripts"Set spFolderItem = spFolder.SelfspPath = spFolderItem.PathspPath = Replace(spPath, ""

27、, "" ' Replace函数的返回值是一个字符串 txtsavepath.Text = spPath ' 把文件夹路径显示在标签上SaveTextPath = txtsavepath.Text ' 路径暂存Err:End SubPrivate Sub CmdClearCounter_Click(On Error GoTo ErrSendCount = 0 ' 发送计数器清零ReceiveCount = 0 ' 接收计数器清零txtRXcount.Text = "RX:" & 0 ' 接收计数tx

28、tTXcount.Text = "TX:" & 0 ' 发送计数Err:End SubPrivate Sub cmdclearrecieve_Click(TxtReceive.Text = ""End SubPrivate Sub cmdclearsend_Click(txtsend.Text = ""End SubPrivate Sub CmdHelp_Click(FrmHelp.ShowEnd SubPrivate Sub CmdQuit_Click(If MSComm.PortOpen = True Then M

29、SComm.PortOpen = False ' 先判断串口是否打 开,如果打开则先关闭Unload Me ' 卸载窗体,并退出程序EndEnd SubPrivate Sub cmdsavedisp_Click(On Error GoTo Err ' 错误处理SaveTextPath = txtsavepath ' 路径暂存Open txtsavepath & "1.txt" For Output As #1 ' 打开文件' 不存在的话 会创建文件 , 如已存在 会覆盖' output 改为 append 为追

30、加' 改为 input 则只读Print #1, Year(Date & "年 " & Month(Date & "月 " & Day(Date & _" 日 " & Hour(Time & "时 " & Minute(Time & "分 " & Second(Time & _" 秒 " & vbCrLf & TxtReceive.Text + vbCrLf 

31、9; 把接收区的文本保存 文本前加上 保存时间 (0000年 00月 00日 00时 00分 00秒' vbcrlf 为回车换行Close #1 ' 关闭文件txtsavepath = "OK,1.txt Save" ' 提示保存成功cmdsavedisp.Enabled = FalseSavetime = Timer ' 记下开始的时间While Timer < Savetime + 5 ' 循环等待 5 - 要延时的时间DoEvents ' 转让控制权,以便让操作系统处理其它的事 件。Wendtxtsavepath

32、= SaveTextPath ' 显示保存路径cmdsavedisp.Enabled = TrueErr:End Sub'= =' 选择要发送的文件并放入内存中'= =Private Sub CmdSelectFile_Click( ' 选择要发送的文件On Error GoTo Err ' 错误处理CommonDialog1.Flags = cdlCFBothCommonDialog1.ShowOpenTxtSendPath.Text = CommonDialog1.FileName ' 把 打 开 的 文 件 名 给 于 TxtSendPathOpen TxtSendPa