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

http://www.programfan.com/article/446.html http://hi.baidu.com/hinzn/blog/item/4e81b4459b390a2ecffca3bb.html http://blog.163.com/modeng_2005/blog/static/265611200981142011329/http://blog.163.com/mod eng_2005/blog/static/265611200981142011329/ Dim OutputAscii As Boolean Dim InputString As String Dim OutputString As String '============================================================================== ======= ' 变量定义 '============================================================================== ======= 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 ' 保存文本路径 ' 网页超链接申明 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 CloseCom() '关闭串口 On Error GoTo Err If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打 开，如果打开则先关闭 txtstatus.Text = "STATUS：COM Port Cloced" ' 串口状态显示 mnuconnect.Caption = "断开串口" cmdswitch.Caption = "打开串口" 'ImgSwitch.Picture = LoadPicture("f:\我的 VB\串口调试软件\图片\guan.jpg") ' 显示串口已经关闭 的图标 ImgSwitchoff.Visible = True ImgSwitchon.Visible = False Err: End Sub Private Sub UpdateStatus() If MSComm.PortOpen Then StatusBar1.Panels(1).Text = "Connected" mnuautosend.Caption = "自动发送" mnuconnect.Caption = "断开串口" Else StatusBar1.Panels(1).Text = "断开串口" mnuautosend.Caption = "disautosend" mnuconnect.Caption = "打开串口" End If StatusBar1.Panels(2).Text = "COM" & MSComm.CommPort StatusBar1.Panels(3).Text = MSComm.Settings If (OutputAscii) Then StatusBar1.Panels(4) = "ASCII" Else StatusBar1.Panels(4) = "HEX" End If ' On Error GoTo Err If ChkAutoSend.Value = 1 Then ' 如果有效则，自动发送 If MSComm.PortOpen = True Then ' 串口状态判断 mnuautosend.Caption = "Dis&autosend" TmrAutoSend.Interval = Val(TxtAutoSendTime) ' 设置自动发送时间 TmrAutoSend.Enabled = True ' 打开自动发送定时器 Else mnuautosend.Caption = "autosend" ChkAutoSend.Value = 0 ' 串口没有打开去掉自动发送 MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提 示打开串口 End If ElseIf ChkAutoSend.Value = 0 Then ' 如果无效，不发送 mnuautosend.Caption = "autosend" TmrAutoSend.Enabled = False ' 关闭自动发送定时器 End If 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 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.InBufferCount = 0 ' 清空输入缓冲区 MSComm.OutBufferCount = 0 ' 清空输出缓冲区 MSComm.SThreshold = 1 ' 发送缓冲区空触发发送事件 MSComm.RThreshold = 1 ' 每X个字符到接收缓冲区引起触发接 收事件 MSComm.OutBufferCount = 0 ' 清空发送缓冲区 MSComm.InBufferCount = 0 ' 滑空接收缓冲 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 = "关闭串口" 'ImgSwitch.Picture = LoadPicture("f:\我的 VB\串口调试软件\图片\kai.jpg") ' 显示串口已经打开的 图标 ImgSwitchoff.Visible = False mnuconnect.Caption = "disconnect" ImgSwitchon.Visible = True txtstatus.Text = "STATUS： " & cbocom.Text & " OPEND， " & cbobaudrate.Text & "," & Left(cboparitybit.Text, 1) & "," & cbodatabit.Text & "," & cbostopbit.Text Else cmdswitch.Caption = "打开串口" 'ImgSwitch.Picture = LoadPicture("f:\我的 VB\串口调试软件\图片\guan.jpg") ' 显示串口已经关闭 的图标 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 Command1_Click() End Sub Private Sub cbobaudrate_Change() Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2)), cbobaudrate.Text, Left(cboparitybit.Text, 1), cbodatabit.Text, cbostopbit.Text) '串口设置 End Sub Private Sub cbocom_Change() Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2)), cbobaudrate.Text, Left(cboparitybit.Text, 1), cbodatabit.Text, cbostopbit.Text) '串口设置 End Sub Private Sub cbodatabit_Change() Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2)), cbobaudrate.Text, Left(cboparitybit.Text, 1), cbodatabit.Text, cbostopbit.Text) '串口设置 End Sub Private Sub cboparitybit_Change() Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2)), cbobaudrate.Text, Left(cboparitybit.Text, 1), cbodatabit.Text, cbostopbit.Text) '串口设置 End Sub Private Sub cbostopbit_Change() Call Comm_reSet(Val(Mid(cbocom.Text, 4, 2)), cbobaudrate.Text, Left(cboparitybit.Text, 1), cbodatabit.Text, cbostopbit.Text) '串口设置 End Sub Private Sub chkautosend_Click() On Error GoTo Err If ChkAutoSend.Value = 1 Then ' 如果有效则，自动发送 If MSComm.PortOpen = True Then ' 串口状态判断 mnuautosend.Caption = "取消自动发送" TmrAutoSend.Interval = Val(TxtAutoSendTime) ' 设置自动发送时间 TmrAutoSend.Enabled = True ' 打开自动发送定时器 Else ChkAutoSend.Value = 0 ' 串口没有打开去掉自动发送 MsgBox "串口没有打开，请打开串口", 48, "串口调试助手" ' 如果串口没有被打开，提 示打开串口 End If ElseIf ChkAutoSend.Value = 0 Then ' 如果无效，不发送 mnuautosend.Caption = "自动发送数据" TmrAutoSend.Enabled = False ' 关闭自动发送定时器 End If 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 CmdClearCounter_Click() On Error GoTo Err SendCount = 0 ' 发送计数器清零 ReceiveCount = 0 ' 接收计数器清零 txtRXcount.Text = "RX:" & 0 ' 接收计数 txtTXcount.Text = "TX:" & 0 ' 发送计数 Err: End Sub Private Sub cmdclearrecieve_Click() TxtReceive.Text = "" End Sub Private Sub cmdclearsend_Click() txtsend.Text = "" End Sub Private Sub CmdHelp_Click() FrmHelp.Show End Sub Private Sub CmdQuit_Click() If MSComm.PortOpen = True Then MSComm.PortOpen = False ' 先判断串口是否打 开，如果打开则先关闭 Unload Me ' 卸载窗体，并退出程序 End 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秒） ' vbcrlf 为回车换行 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 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 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 cmdstopdisp_Click() On Error GoTo Err If DisplaySwitch = False Then DisplaySwitch = True ' 关闭显示 cmdstopdisp.Caption = "继续显示" Else DisplaySwitch = False ' 开启显示 cmdstopdisp.Caption = "停止显示" End If Err: End Sub