'**********************************
'窗体 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
'******************************************