基于VB做的串口编程调试软件

'**********************************

'窗体 main(main.frm)_程序
'**********************************

'**********************************
'字符表示的十六进制数转化为相应的整数
'错误则返回 -1
'**********************************

Function ConvertHexChr(str As String) As Integer

Dim test As Integer

test = Asc(str)
If test = Asc("0") And test = Asc("9") Then
test = test - Asc("0")
ElseIf test = Asc("a") And test = Asc("f") Then
test = test - Asc("a") + 10
ElseIf test = Asc("A") And test = Asc("F") Then
test = test - Asc("A") + 10
Else
test = -1 '出错信息
End If
ConvertHexChr = test

End Function

'**********************************
'字符串表示的十六进制数据转化为相应的字节串
'返回转化后的字节数
'**********************************

Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer

Dim HexData As Integer '十六进制(二进制)数据字节对应值
Dim hstr As String * 1 '高位字符
Dim lstr As String * 1 '低位字符
Dim HighHexData As Integer '高位数值
Dim LowHexData As Integer '低位数值
Dim HexDataLen As Integer '字节数
Dim StringLen As Integer '字符串长度
Dim ACCount As Integer '计数

strTestn = "" '设初值
HexDataLen = 0
strHexToByteArray = 0

StringLen = Len(strText)
Account = StringLen \ 2
ReDim bytByte(Account)

For n = 1 To StringLen

Do '清除空格
hstr = Mid(strText, n, 1)
n = n + 1
If (n - 1) StringLen Then
HexDataLen = HexDataLen - 1

Exit For
End If
Loop While hstr = " "

Do
lstr = Mid(strText, n, 1)
n = n + 1
If (n - 1) StringLen Then
HexDataLen = HexDataLen - 1

Exit For
End If
Loop While lstr = " "
n = n - 1
If n StringLen Then
HexDataLen = HexDataLen - 1
Exit For
End If

HighHexData = ConvertHexChr(hstr)
LowHexData = ConvertHexChr(lstr)

If HighHexData = -1 Or LowHexData = -1 Then '遇到非法字符中断转化
HexDataLen = HexDataLen - 1

Exit For
Else

HexData = HighHexData * 16 + LowHexData
bytByte(HexDataLen) = HexData
HexDataLen = HexDataLen + 1


End If

Next n

If HexDataLen 0 Then '修正最后一次循环改变的数值
HexDataLen = HexDataLen - 1
ReDim Preserve bytByte(HexDataLen)
Else
ReDim Preserve bytByte(0)
End If


If StringLen = 0 Then '如果是空串,则不会进入循环体
strHexToByteArray = 0
Else
strHexToByteArray = HexDataLen + 1
End If


End Function

Private Sub combo_ClICk()

If Main.combo.Text = "按ASCII码" Then
intOutMode = 0

Else
intOutMode = 1

End If

End Sub

Private Sub chkAddress_Click()

If chkAddress.Value = 0 Then
intAddressChk = 0
Else
intAddressChk = 1
End If

Call ScrollRedisplay

End Sub

Private Sub chkAddress48_Click()

If chkAddress48.Value = 1 Then
intAdd48Chk = 1
Else
intAdd48Chk = 0
End If

Call SlideRedisplay

End Sub

Private Sub chkAscii_Click()

If chkAscii.Value = 1 Then
intAsciiChk = 1
Else
intAsciiChk = 0
End If

Call ScrollRedisplay

End Sub

Private Sub chkHex_Click()

If chkHex.Value = 0 Then
intHexChk = 0
Else
intHexChk = 1
End If

Call ScrollRedisplay

End Sub

Private Sub send_Click()

If blnAutoSendFlag Then

Main.CTRTimer.EnabLED = False

If Not blnReceiveFlag Then
Main.ctrMSComm.PortOpen = False
End If

Main.send.Caption = "自动发送"
Else
If Not Main.ctrMSComm.PortOpen Then
Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

Main.ctrTimer.Interval = intTime
Main.ctrTimer.Enabled = True
Main.send.Caption = "停止发送"
End If



blnAutoSendFlag = Not blnAutoSendFlag


End Sub

Private Sub clear_Click()

Dim bytTemp(0) As Byte

ReDim bytReceiveByte(0)
intReceiveLen = 0

Call InputManage(bytTemp, 0)

Call GetDisplayText
Call display


End Sub

Private Sub send2_Click()

If Not Main.ctrMSComm.PortOpen Then
Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

Call ctrTimer_Timer

If Not blnAutoSendFlag Then

Main.ctrMSComm.PortOpen = False
End If

End Sub

Private Sub Receive_Click()


If blnReceiveFlag Then

If Not blnAutoSendFlag And Not blnReceiveFlag Then
Main.ctrMSComm.PortOpen = False
End If

Main.Receive.Caption = "开始接收"
Else

If Not Main.ctrMSComm.PortOpen Then
Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

Main.ctrMSComm.InputLen = 0
Main.ctrMSComm.InputMode = 0


Main.ctrMSComm.InBufferCount = 0
Main.ctrMSComm.RThreshold = 1
Main.Receive.Caption = "停止接收"
End If

blnReceiveFlag = Not blnReceiveFlag


End Sub

Private Sub setting_Click()

config.Show
config.Port.Text = str(intPort)
config.Setting.Text = strSet
config.Time.Text = str(intTime)

End Sub

Private Sub ctrMSComm_OnComm()

Dim bytInput() As Byte
Dim intInputLen As Integer


Select Case Main.ctrMSComm.CommEvent


Case comEvReceive
If blnReceiveFlag Then

If Not Main.ctrMSComm.PortOpen Then
Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

'此处添加处理接收的代码

Main.ctrMSComm.InputMode = comInputModeBinary
intInputLen = Main.ctrMSComm.InBufferCount
ReDim bytInput(intInputLen)
bytInput = Main.ctrMSComm.Input
Call InputManage(bytInput, intInputLen)
Call GetDisplayText
Call display


If Not blnAutoSendFlag And Not blnReceiveFlag Then
Main.ctrMSComm.PortOpen = False
End If
End If

End Select

End Sub

Private Sub ctrTimer_Timer()
Dim longth As Integer

strSendText = Main.txtSend.Text
If intOutMode = 0 Then
Main.txtReceive.Text = "ascii"
Main.ctrMSComm.Output = strSendText
Else
'add code
longth = strHexToByteArray(strSendText, bytSendByte())

If longth 0 Then
Main.ctrMSComm.Output = bytSendByte
End If

End If

End Sub

'*****************************************
'初始化
'*****************************************

Private Sub Form_Load()
If ctrMSComm.PortOpen = False Then

ctrMSComm.PortOpen = True

End If

'设置默认发送接收关闭状态
blnAutoSendFlag = False
blnReceiveFlag = False

'接收初始化
intReceiveLen = 0

'默认发送方式为ASCII
intOutMode = 0
Main.combo.Text = "按ASCII码"

'默认显示宽度位数为8
intHexWidth = 8


'默认各复选框处于选定状态
intHexChk = 1
intAsciiChk = 1
intAddressChk = 1
intAdd48Chk = 1

Main.chkAddress.Value = intAddressChk
Main.chkAscii.Value = intAsciiChk
Main.chkHex.Value = intHexChk
Main.chkAddress48.Value = intAdd48Chk



'显示初始化
Call clear_Click

'初始化串行口
intPort = 2
intTime = 1000
strSet = "9600,n,8,1"


If Not Main.ctrMSComm.PortOpen Then
Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

Main.ctrMSComm.PortOpen = False


End Sub

Private Sub sldLenth_Change(Index As Integer)

intHexWidth = Main.sldLenth(0).Value
Call SlideRedisplay

End Sub

'**********************************

'***************************************************************

'窗体 config(config.frm)_程序

'***************************************************************

'**********************************

Private Sub CANcel_Click()

config.Hide
Unload config

End Sub

Private Sub ok_Click()

On Error GoTo SettingError

intPort = Val(config.Port.Text)
intTime = Val(config.time.Text)
strSet = config.setting.Text



If Not Main.ctrMSComm.PortOpen Then

Main.ctrMSComm.CommPort = intPort
Main.ctrMSComm.Settings = strSet
Main.ctrMSComm.PortOpen = True
End If

If Not blnAutoSendFlag And Not blnReceiveFlag Then
Main.ctrMSComm.PortOpen = False
End If
config.Hide
Unload config

Exit Sub

SettingError:
intPort = 2
intTime = 1000
strSet = "9600,n,8,1"
config.Show
config.Port.Text = str(intPort)
config.setting.Text = strSet
config.time.Text = str(intTime)

MsgBox (Error(Err.Number))

End Sub

'**********************************

'模块 Modeule(Modeule.bas)_程序
'**********************************

' 基本设置

Public intPort As Integer '串行口号
Public strSet As String '协议设置
Public intTime As Integer '发送时间间隔

'发送与接收标志

Public blnAutoSendFlag As Boolean '发送标志
Public blnReceiveFlag As Boolean '接收标志

'发送模块

Public intOutMode As Integer '发送模式
Public strSendText As String '发送文本数据
Public bytSendByte() As Byte '发送二进制数据

'显示标志

Public intHexChk As Integer '十六进制编码标志
Public intAsciiChk As Integer 'ASCII码标志
Public intAddressChk As Integer '地址标志
Public intAdd48Chk As Integer '4/8位地址标志

'**********************************

'模块 Modeule1(Modeule1.bas)_程序
'**********************************

'接收模块

Public bytReceiveByte() As Byte '接收到的字节
Public intReceiveLen As Integer '接收到的字节数

'显示模块

Public strAddress As String '地址信息
Public strHex As String '十六进制编码
Public strAscii As String 'ASCII码

Public intHexWidth As Integer '显示列数

Public intOriginX As Long '横向原点(像素)
Public intOriginY As Integer '纵向原点(行)
Public intLine As Integer '总行数

'显示常量

Public Const ChrWidth = 105 '单位宽度
Public Const ChrHeight = 2 * ChrWidth '单位高度
Public Const BorderWidth = 210 '预留边界
Public Const LineMax = 16 '最大显示行数

'**********************************
'输入处理
'处理接收到的字节流,并保存在全局变量
'bytReceiveRyte()
'**********************************

Public Sub InputManage(bytInput() As Byte, intInputLenth As Integer)

Dim n As Integer '定义变量及初始化

ReDim Preserve bytReceiveByte(intReceiveLen + intInputLenth)

For n = 1 To intInputLenth Step 1
bytReceiveByte(intReceiveLen + n - 1) = bytInput(n - 1)
Next n

intReceiveLen = intReceiveLen + intInputLenth

End Sub

'为输出准备文本
'保存在全局变量
'strText
'strHex
'strAddress
'总行数保存在
'intLine

Public Sub GetDisplayText()

Dim n As Integer
Dim intValue As Integer
Dim intHighHex As Integer
Dim intLowHex As Integer
Dim strSingleChr As String * 1

Dim intAddress As Integer
Dim intAddressArray(8) As Integer
Dim intHighAddress As Integer



strAscii = "" '设置初值
strHex = ""
strAddress = ""

'*****************************************
'获得16进制码和ASCII码的字符串
'*****************************************



For n = 1 To intReceiveLen
intValue = bytReceiveByte(n - 1)

If intValue 32 Or intValue 128 Then '处理非法字符
strSingleChr = Chr(46) '对于不能显示的ASCII码,
Else '用"."表示
strSingleChr = Chr(intValue)
End If

strAscii = strAscii + strSingleChr

intHighHex = intValue \ 16
intLowHex = intValue - intHighHex * 16

If intHighHex 10 Then
intHighHex = intHighHex + 48
Else
intHighHex = intHighHex + 55
End If
If intLowHex 10 Then
intLowHex = intLowHex + 48
Else
intLowHex = intLowHex + 55
End If

strHex = strHex + " " + Chr$(intHighHex) + Chr$(intLowHex) + " "

If (n Mod intHexWidth) = 0 Then '设置换行
strAscii = strAscii + Chr$(13) + Chr$(10)
strHex = strHex + Chr$(13) + Chr$(10)
Else

End If
Next n



'***************************************
'获得地址字符串
'***************************************

intLine = intReceiveLen \ intHexWidth

If (intReceiveLen - intHexWidth * intLine) 0 Then
intLine = intLine + 1
End If

For n = 1 To intLine
intAddress = (n - 1) * intHexWidth

If intAdd48Chk = 1 Then
intHighAddress = 8
Else
intHighAddress = 4
End If
intAddressArray(0) = intAddress
For m = 1 To intHighAddress
intAddressArray(m) = intAddressArray(m - 1) \ 16
Next m
For m = 1 To intHighAddress
intAddressArray(m - 1) = intAddressArray(m - 1) - intAddressArray(m) * 16
Next m
For m = 1 To intHighAddress

If intAddressArray(intHighAddress - m) 10 Then
intAddressArray(intHighAddress - m) = intAddressArray(intHighAddress - m) + Asc("0")

Else
intAddressArray(intHighAddress - m) = intAddressArray(intHighAddress - m) + Asc("A") - 10

End If
strAddress = strAddress + Chr$(intAddressArray(intHighAddress - m))
Next m

strAddress = strAddress + Chr$(13) + Chr$(10) '设置换行

Next n


'***************************************
End Sub

'*************************************
'显示输出
'*************************************

Public Sub display()

Dim intViewWidth As Long '横向宽度(像素)
Dim intViewLine As Integer '纵向宽度(行)

Dim strDisplayAddress As String
Dim strDisplayHex As String
Dim strDisplayAscii As String

strDisplayAddress = ""
strDisplayHex = ""
strDisplayAscii = ""

Dim intStart As Integer
Dim intLenth As Integer




intStart = intOriginY * (intHexWidth + 2) + 1
intLenth = intViewLine * (intHexWidth + 2)
strDisplayAscii = Mid(strAscii, intStart, intLenth)







End Sub

'******************************************
'文本无变化的刷新
'******************************************

Public Sub ScrollRedisplay()

Call display

End Sub

'******************************************
'文本发生变化的刷新
'******************************************

Public Sub SlideRedisplay()

Call GetDisplayText
Call display

End Sub

'******************************************