VB串口調試軟件源代碼

ID:323859 · 發表于 2018-5-6 23:13

VB串口調試軟件的運行界面如下：

源碼工程資料包：

vb源程序如下:

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 串口調試軟件
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "串口調試軟件V1.0"
ClientHeight = 6360
ClientLeft = 4020
ClientTop = 3120
ClientWidth = 10815
FillColor = &H0091CACA&
ForeColor = &H0091CACA&
Icon = "串口調試助手.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
Picture = "串口調試助手.frx":030A
ScaleHeight = 6360
ScaleWidth = 10815
Begin MSComDlg.CommonDialog CommonDialog1
Left = 8160
Top = 5880
_ExtentX = 847
_ExtentY = 847
_Version = 393216
Filter = "文本文件（*.txt）|*.txt"
End
Begin VB.Timer TmrNowTime
Interval = 1000
Left = 1320
Top = 4320
End
Begin VB.Timer TmrAutoSend
Left = 7680
Top = 5880
End
Begin MSCommLib.MSComm MSComm
Left = 7080
Top = 5760
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
End
Begin VB.PictureBox Picture1
BackColor = &H00E0E0E0&
Height = 500
Left = 9360
Picture = "串口調試助手.frx":3EEC
ScaleHeight = 435
ScaleWidth = 435
TabIndex = 43
Top = 5850
Width = 500
End
Begin VB.TextBox TxtAutoSendTime
Height = 300
Left = 1320
TabIndex = 41
Text = "1000"
Top = 5730
Width = 660
End
Begin VB.CommandButton CmdAmend
Appearance = 0 'Flat
Caption = "更改"
Height = 300
Left = 1250
TabIndex = 37
Top = 3450
Width = 505
End
Begin VB.CommandButton CmdSaveDisp
Appearance = 0 'Flat
Caption = "保存顯示數據"
Height = 300
Left = 30
TabIndex = 36
Top = 3450
Width = 1225
End
Begin VB.CommandButton CmdHelp
Caption = "關于"
Height = 300
Left = 8760
TabIndex = 21
Top = 6050
Width = 505
End
Begin VB.CommandButton CmdQuit
Caption = "關閉程序"
Height = 495
Left = 9900
TabIndex = 20
Top = 5820
Width = 870
End
Begin VB.CommandButton CmdClearCounter
Caption = "計數清零"
Height = 300
Left = 6100
TabIndex = 19
Top = 6080
Width = 865
End
Begin VB.CommandButton CmdSendFile
Caption = "發送文件"
Height = 280
Left = 5580
TabIndex = 18
Top = 5700
Width = 900
End
Begin VB.TextBox TxtSendPath
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 3800
TabIndex = 17
Text = "還沒有選擇文件"
Top = 5740
Width = 1700
End
Begin VB.CommandButton CmdSelectFile
Caption = "選擇發送文件"
Height = 280
Left = 2520
TabIndex = 16
Top = 5700
Width = 1225
End
Begin VB.TextBox TxtTXCount
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 4680
TabIndex = 15
Text = "TX:0"
Top = 6080
Width = 1340
End
Begin VB.TextBox TxtRXCount
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 3340
TabIndex = 14
Text = "RX:0"
Top = 6080
Width = 1350
End
Begin VB.TextBox TxtStatus
Alignment = 2 'Center
BackColor = &H0091CACA&
Height = 270
Left = 260
TabIndex = 13
Top = 6080
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 = 3760
Width = 1650
End
Begin VB.CheckBox ChkHexReceive
BackColor = &H0091CACA&
Caption = "Check2"
Height = 255
Left = 50
TabIndex = 6
Top = 3100
Width = 255
End
Begin VB.CheckBox ChkAutoClear
BackColor = &H0091CACA&
Caption = "Check1"
Height = 255
Left = 50
TabIndex = 5
Top = 2850
Width = 255
End
Begin VB.CommandButton CmdStopdisp
Caption = "停止顯示"
Height = 310
Left = 30
TabIndex = 4
Top = 2520
Width = 1050
End
Begin VB.CommandButton CmdClearReceive
Caption = "清空接收區"
Height = 310
Left = 30
TabIndex = 3
Top = 2190
Width = 1050
End
Begin VB.Frame Frame1
BackColor = &H0091CACA&
Height = 2200
Left = 0
TabIndex = 2
Top = -100
Width = 1650
Begin VB.ComboBox CboStopbit
Height = 300
ItemData = "串口調試助手.frx":7ACE
Left = 750
List = "串口調試助手.frx":7ADB
TabIndex = 26
Text = "1"
Top = 1300
Width = 800
End
Begin VB.ComboBox CboDatabit
Height = 300
ItemData = "串口調試助手.frx":7AEA
Left = 750
List = "串口調試助手.frx":7AFA
TabIndex = 25
Text = "8"
Top = 1000
Width = 800
End
Begin VB.ComboBox CboParitybit
Height = 300
ItemData = "串口調試助手.frx":7B0A
Left = 750
List = "串口調試助手.frx":7B1D
TabIndex = 24
Text = "NONE"
Top = 700
Width = 800
End
Begin VB.ComboBox CboBaudrate
Height = 300
ItemData = "串口調試助手.frx":7B3F
Left = 750
List = "串口調試助手.frx":7B6A
TabIndex = 23
Text = "9600"
Top = 400
Width = 800
End
Begin VB.ComboBox CboCom
Height = 300
ItemData = "串口調試助手.frx":7BC3
Left = 750
List = "串口調試助手.frx":7BF4
TabIndex = 22
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
Picture = "串口調試助手.frx":7C58
Top = 1680
Width = 450
End
Begin VB.Image ImgSwitchOff
Height = 420
Left = 120
Picture = "串口調試助手.frx":B6F5
Top = 1680
Width = 450
End
Begin VB.Label Label8
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "停止位"
Height = 255
Left = 50
TabIndex = 33
Top = 1400
Width = 600
End
Begin VB.Label Label7
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "數據位"
Height = 255
Left = 50
TabIndex = 32
Top = 1080
Width = 600
End
Begin VB.Label Label6
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "校驗位"
Height = 255
Left = 50
TabIndex = 31
Top = 760
Width = 600
End
Begin VB.Label Label5
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "波特率"
Height = 255
Left = 50
TabIndex = 30
Top = 470
Width = 600
End
Begin VB.Label Label4
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "串口"
Height = 255
Left = 50
TabIndex = 29
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 LblWeb
BackColor = &H0091CACA&
Caption = "WEB"
ForeColor = &H008A7839&
Height = 220
Left = 8880
MouseIcon = "串口調試助手.frx":EE3B
TabIndex = 46
Top = 5760
Width = 300
End
Begin VB.Label LblNewDate
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "顯示日前"
Height = 255
Left = 240
TabIndex = 45
Top = 4440
Width = 1215
End
Begin VB.Label LblNowTime
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "當前時間"
ForeColor = &H00000000&
Height = 195
Left = 240
TabIndex = 44
Top = 4200
Width = 1215
End
Begin VB.Label Label14
BackColor = &H0091CACA&
Caption = "毫秒"
Height = 255
Left = 2000
TabIndex = 42
Top = 5760
Width = 450
End
Begin VB.Label LblArtoSendCyc
BackColor = &H0091CACA&
Caption = "自動發送周期："
Height = 200
Left = 60
TabIndex = 40
Top = 5760
Width = 1270
End
Begin VB.Label LblAutoSend
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "自動發送(周期改變后重選)"
Height = 200
Left = 240
TabIndex = 39
Top = 5510
Width = 2215
End
Begin VB.Label Label11
Alignment = 2 'Center
BackColor = &H0091CACA&
Caption = "十六進制發送"
Height = 200
Left = 240
TabIndex = 38
Top = 5200
Width = 1200
End
Begin VB.Label Label10
BackColor = &H0091CACA&
Caption = "十六進制顯示"
Height = 200
Left = 330
TabIndex = 35
Top = 3140
Width = 1200
End
Begin VB.Label LblArtoclear
BackColor = &H0091CACA&
Caption = "自動清空"
Height = 200
Left = 330
TabIndex = 34
Top = 2870
Width = 800
End
Begin VB.Label LblSend
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "發送的字符/數據"
Height = 270
Left = 1100
TabIndex = 28
Top = 4850
Width = 1420
End
Begin VB.Label LblReceive
BackColor = &H0091CACA&
BorderStyle = 1 'Fixed Single
Caption = "接收區"
Height = 255
Left = 1130
TabIndex = 27
Top = 2180
Width = 595
End
End
Attribute VB_Name = "串口調試軟件"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================================================================
' 變量定義
'=====================================================================================
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 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://blog.163.com/zhaojun_xf/", "", "", 5 ' 要打開的網站
End Sub
' 鼠標移入 WEB 區
Private Sub LblWeb_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LblWeb.ForeColor = &H8A7839 ' 鼠標移入WEB時的顏色
LblWeb.MousePointer = 99 ' 鼠標移入WEB時的鼠標的現狀 ,小手型
'LblWeb.MouseIcon = LoadPicture("f:\我的VB\串口調試軟件\圖片\mouse.cur") ' 鼠標形狀圖片
End Sub
' 鼠標移出 WEB 區
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
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 Form_Load() ' 載入窗體
On Error GoTo Err
LblWeb.FontUnderline = True ' WEB上加下劃線
LblWeb.ForeColor = vbBlue ' 藍色顯示WEB
TxtSend.Text = "http://www.newxing.com/" ' 載入發送信息
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 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 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 textReceive()
On Error GoTo Err
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 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 hexSend()
On Error Resume Next
Dim outputLen As Integer ' 發送數據長度
Dim outData As String ' 發送數據暫存
Dim SendArr() As Byte ' 發送數組
Dim TemporarySave As String ' 數據暫存
Dim dataCount As Integer ' 數據個數計數
Dim i As Integer ' 局部變量
outData = UCase(Replace(TxtSend.Text, 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 Sub
End If
Next
If dataCount Mod 2 <> 0 Then ' 判斷十六進制數據是否為雙數
dataCount = dataCount - 1 ' 不是雙數，則減1
End If
outData = Left(outData, dataCount) ' 取出有效的十六進制數據
ReDim SendArr(dataCount / 2 - 1) ' 重新定義數組長度
For i = 0 To dataCount / 2 - 1
SendArr(i) = Val("&H" + Mid(outData, i * 2 + 1, 2)) ' 取出數據轉換成十六進制并放入數組中
Next
SendCount = SendCount + (dataCount / 2) ' 計算總發送數
TxtTXCount.Text = "TX:" & SendCount
MSComm.Output = SendArr ' 發送數據
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 = "" ' 清緩沖
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 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 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") ' 顯示串口已經打開的圖標
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
'ImgSwitch.Picture = LoadPicture("f:\我的VB\串口調試軟件\圖片\guan.jpg") ' 顯示串口已經關閉的圖標
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 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 = "打開串口"
'ImgSwitch.Picture = LoadPicture("f:\我的VB\串口調試軟件\圖片\guan.jpg") ' 顯示串口已經關閉的圖標
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 = "打開串口"
'ImgSwitch.Picture = LoadPicture("f:\我的VB\串口調試軟件\圖片\guan.jpg") ' 顯示串口已經關閉的圖標
ImgSwitchOn.Visible = False
ImgSwitchOff.Visible = True
Err:
End Sub
'=====================================================================================
' 顯示時間
'=====================================================================================
Private Sub TmrNowTime_Timer()
LblNewDate.Caption = Date ' 顯示時間
LblNowTime.Caption = Time ' 顯示系統時間
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
'--------------- 程序結束 ------------------

復制代碼

所有資料51hei提供下載:

VB 串口調試軟件源代碼.rar (50.04 KB, 下載次數: 176)

ID:328112 · 發表于 2019-5-22 21:44

CommonDialog1.Flags = cdlCFBoth 編譯不能通過.顯示變量未定義////

ID:74872 · 發表于 2019-6-4 16:12

下載學習，感謝分享

ID:298008 · 發表于 2020-4-26 20:41

謝謝樓主分享！！！

ID:298008 · 發表于 2020-4-26 20:51

謝謝樓主分享！！！

帳號		自動登錄	找回密碼
密碼			立即注冊

久久久久久久999_99精品久久精品一区二区爱城_成人欧美一区二区三区在线播放_国产精品日本一区二区不卡视频_国产午夜视频_欧美精品在线观看免费

VB串口調試軟件源代碼