标准模块:
Option Explicit
Public fMainForm As frmMain
Public yibiao_weizhi(10) As Integer
Public dizhi1 As String * 2
Public main_i As Integer
Public i As Integer
Public j As Integer
Public fasong_sj(10, 5) As String
Public xh As Integer
Public dizhi As Integer
Public sj_bm(10, 5) As Single
Public number As Byte
Public setMingling(10) As String * 16
Public alame(10) As String * 1
Public record_jm(5) As Single
Public a As Double
Public PRINT_Cs(14) As String
Public PRINT_WzCs(12) As String
Public shiYAnH As String
Public shiYAnTime As String
Public shiyan_sj(4) As String
Public print_fg As Byte
Option Explicit
Dim sum_zs
Dim xuhao_zs As String * 2
Dim i As Byte
Dim j As Byte
Dim ccl(2) As String * 1
Dim blL As String * 2
Dim bl As String * 1
Dim cclL(2) As String * 4
Dim bl_dm As String * 4
Dim zt_dm1 As String * 8
Dim jieshou_sj As String * 6
Dim sum As Byte
Dim sum1 As Byte
Dim xuhao As String * 2
Dim fa0 As String * 2
Dim HexStr1 As String * 20
' 基本设置
Private intPort As Integer '串行口号
Private strSet As String '协议设置
Private intTime As Integer '发送时间间隔
'发送与接收标志
Private blnAutoSendFlag As Boolean '发送标志
Private blnAutoSendFlag1 As Boolean '发送标志
Private blnReceiveFlag As Boolean'接收标志
'发送模块
Private intOutMode As Integer'发送模式消慎
Private strSendText As String'发送文本数据
Private bytSendByte() As Byte'发送二进制数据
'显示标志
Private intHexChk As Integer '十六进制编码标志
Private intAsciiChk As Integer 'ASCII码标志
Private intAddressChk As Integer '地址标志
Private intAdd48Chk As Integer '4/8位地址标志
'接收模块
Private bytReceiveByte() As Byte '接收到的字节
Private intReceiveLen As Integer '接收到的字节数
Private strTestn As String
'显示模块
Private strAddress As String '地址信息
Private strHex As String '十六进枝笑制编码
Private strAscii As String'ASCII码
Private intHexWidth As Integer '显示列数
'
Private intOriginX As Long '横向原点(像素)
Private intOriginY As Integer'纵向原点(行)
Private intLine As Integer '总行数
'
Dim m As Integer
Dim blnChakanFlag As Boolean
'显示常量
Private Const ChrWidth = 105 '单位宽度
Private Const ChrHeight = 2 * ChrWidth '单位高度
Private Const BorderWidth = 210 '预留边界
Private Const LineMax = 16 '最大显示行数
'输入处理
'处理接收到的字节流,并保存在全局变量
'bytReceiveRyte()
Private 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
Private 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
Dim HexStr As String
On Error GoTo abc
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
HexStr = HexStr &Chr$(intHighHex) &Chr$(intLowHex)
HexStr1 = HexStr '传递数据
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
'Text1 = "Ok"
Exit Sub
abc:
'Text1 = "Error"
Resume
End Sub
'显示输出
Private 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
'调整显示页面大小,设置滚动位置宽度
If intAdd48Chk = 1 Then
frmMain.txtHexEditAddress.Width = 8 * ChrWidth + BorderWidth
Else
frmMain.txtHexEditAddress.Width = 4 * ChrWidth + BorderWidth
End If
frmMain.txtHexEditHex.Width = intHexWidth * 4 * ChrWidth + BorderWidth
frmMain.txtHexEditText.Width = intHexWidth * ChrWidth + BorderWidth
frmMain.txtBlank.Width = BorderWidth
intViewWidth = frmMain.txtHexEditAddress.Width * intAddressChk + frmMain.txtHexEditHex.Width * intHexChk + frmMain.txtHexEditText.Width * intAsciiChk
If intViewWidth <= frmMain.fraHexEditBackground.Width And intLine <LineMax Then
frmMain.txtBlank.Width = frmMain.fraHexEditBackground.Width - intViewWidth
frmMain.hsclHexEdit.Visible = False
frmMain.vsclHexEdit.Visible = False
intViewWidth = frmMain.fraHexEditBackground.Width
intViewLine = intLine
intOriginX = 0
intOriginY = 0
ElseIf intViewWidth >frmMain.fraHexEditBackground.Width And intLine <LineMax - 1 Then
frmMain.hsclHexEdit.Visible = True
frmMain.vsclHexEdit.Visible = False
frmMain.hsclHexEdit.Width = frmMain.fraHexEditBackground.Width
intViewLine = intLine
intOriginY = 0
If intOriginX >intViewWidth - frmMain.fraHexEditBackground.Width Then
intOriginX = intViewWidth - frmMain.fraHexEditBackground.Width
End If
ElseIf intViewWidth <(frmMain.fraHexEditBackground.Width - frmMain.vsclHexEdit.Width) And intLine >= LineMax Then
frmMain.vsclHexEdit.Visible = True
frmMain.hsclHexEdit.Visible = False
frmMain.txtBlank.Width = frmMain.fraHexEditBackground.Width - intViewWidth
intViewWidth = frmMain.fraHexEditBackground.Width
intViewLine = LineMax
intOriginX = 0
If intOriginY >intLine - LineMax Then
intOriginY = intLine - LineMax
End If
Else
frmMain.hsclHexEdit.Visible = True
frmMain.vsclHexEdit.Visible = True
frmMain.hsclHexEdit.Width = frmMain.fraHexEditBackground.Width - frmMain.vsclHexEdit.Width
intViewLine = LineMax - 1
If intOriginX >intViewWidth - frmMain.fraHexEditBackground.Width Then
intOriginX = intViewWidth - frmMain.fraHexEditBackground.Width
End If
If intOriginY >intLine - LineMax + 1 Then
intOriginY = intLine - LineMax + 1
End If
End If
frmMain.txtHexEditAddress.Left = intOriginX
frmMain.txtHexEditHex.Left = intOriginX + frmMain.txtHexEditAddress.Width * intAddressChk
frmMain.txtHexEditText.Left = intOriginX + frmMain.txtHexEditAddress.Width * intAddressChk + frmMain.txtHexEditHex.Width * intHexChk
frmMain.txtBlank.Left = intOriginX + frmMain.txtHexEditAddress.Width * intAddressChk + frmMain.txtHexEditHex.Width * intHexChk + frmMain.txtHexEditText.Width * intAsciiChk
intStart = intOriginY * (6 + 4 * intAdd48Chk) + 1
intLenth = intViewLine * (6 + 4 * intAdd48Chk)
strDisplayAddress = Mid(strAddress, intStart, intLenth)
intStart = intOriginY * (intHexWidth * 4 + 2) + 1
intLenth = intViewLine * (intHexWidth * 4 + 2)
strDisplayHex = Mid(strHex, intStart, intLenth)
intStart = intOriginY * (intHexWidth + 2) + 1
intLenth = intViewLine * (intHexWidth + 2)
strDisplayAscii = Mid(strAscii, intStart, intLenth)
'设置滚动条
frmMain.vsclHexEdit.Max = intLine - intViewLine
frmMain.hsclHexEdit.Max = (intViewWidth - frmMain.fraHexEditBackground.Width) \ ChrWidth + 1
'显示输出
frmMain.txtHexEditHex.Text = strDisplayHex
frmMain.txtHexEditText.Text = strDisplayAscii
frmMain.txtHexEditAddress.Text = strDisplayAddress
End Sub
'文本无变化的刷新
Private Sub ScrollRedisplay()
Call display
End Sub
'文本发生变化的刷新
Private Sub SlideRedisplay()
Call GetDisplayText
Call display
End Sub
'字符表示的十六进制数转化为相应的整数,错误则返回 -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
Dim n As Long
'计数
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
Public Function Hex_bin()
'输出口状态鉴别
For i = 1 To 2
ccl(i) = Mid(blL, i, 1)
If ccl(i) >= Chr(48) And ccl(i) <= Chr(57) Or ccl(i) >= Chr(65) And ccl(i) <= Chr(70) Then
ccl(i) = ccl(i)
Else
Exit Function '退出过程函数
ccl(i) = "0"
End If
Next i
For j = 1 To 2
bl = ccl(j)
If bl = "F" Then
bl_dm = "1111"
ElseIf bl = "E" Then
bl_dm = "1110"
ElseIf bl = "D" Then
bl_dm = "1101"
ElseIf bl = "C" Then
bl_dm = "1100"
ElseIf bl = "B" Then
bl_dm = "1011"
ElseIf bl = "A" Then
bl_dm = "1010"
ElseIf bl = "9" Then
bl_dm = "1001"
ElseIf bl = "8" Then
bl_dm = "1000"
ElseIf bl = "7" Then
bl_dm = "0111"
ElseIf bl = "6" Then
bl_dm = "0110"
ElseIf bl = "5" Then
bl_dm = "0101"
ElseIf bl = "4" Then
bl_dm = "0100"
ElseIf bl = "3" Then
bl_dm = "0011"
ElseIf bl = "2" Then
bl_dm = "0010"
ElseIf bl = "1" Then
bl_dm = "0001"
ElseIf bl = "0" Then
bl_dm = "0000"
Else:
bl_dm = ""
End If
cclL(j) = bl_dm
Next j
zt_dm1 = cclL(1) + cclL(2)
For i = 1 To 8
'zt_dm(i) = Mid$(zt_dm1, i, 1)
Next i
End Function
Private Sub cboHexAscii_Click()
If frmMain.cboHexAscii.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 cmdAutoSend_Click()
If blnAutoSendFlag Then
frmMain.ctrTimer.Enabled = False
If Not blnReceiveFlag Then
frmMain.ctrMSComm.PortOpen = False
End If
frmMain.cmdAutoSend.Caption = "自动寻址"
Else
If Not frmMain.ctrMSComm.PortOpen Then
frmMain.ctrMSComm.CommPort = intPort
frmMain.ctrMSComm.Settings = strSet
frmMain.ctrMSComm.PortOpen = True
End If
frmMain.ctrTimer.Interval = intTime
frmMain.ctrTimer.Enabled = True
frmMain.cmdAutoSend.Caption = "停止寻址"
End If
blnAutoSendFlag = Not blnAutoSendFlag
End Sub
Private Sub cmdAutoSend1_Click()
'用于设置参数
If blnAutoSendFlag1 Then
Call cmdAutoSend_Click
frmMain.ctrTimer1.Enabled = False
frmMain.cmdAutoSend1.Caption = "自动设置"
Else
If Not frmMain.ctrMSComm.PortOpen Then
frmMain.ctrMSComm.CommPort = intPort
frmMain.ctrMSComm.Settings = strSet
frmMain.ctrMSComm.PortOpen = True
End If
Call cmdAutoSend_Click
frmMain.cmdAutoSend1.Caption = "停止设置"
frmMain.ctrTimer1.Enabled = True
End If
blnAutoSendFlag1 = Not blnAutoSendFlag1
End Sub
Private Sub cmdChakan_Click()
If blnChakanFlag Then
frmMain.cmdChakan.Caption = "查看"
frmMain.Height = 2800
Else
frmMain.cmdChakan.Caption = "恢复"
frmMain.Height = 6700
End If
blnChakanFlag = Not blnChakanFlag
End Sub
Private Sub cmdClear_Click()
Dim bytTemp(0) As Byte
ReDim bytReceiveByte(0)
intReceiveLen = 0
Call InputManage(bytTemp, 0)
Call GetDisplayText
Call display
End Sub
Private Sub cmdManualSend_Click()
If Not frmMain.ctrMSComm.PortOpen Then
frmMain.ctrMSComm.CommPort = intPort
frmMain.ctrMSComm.Settings = strSet
frmMain.ctrMSComm.PortOpen = True
End If
Call ctrTimer_Timer
If Not blnAutoSendFlag Then
frmMain.ctrMSComm.PortOpen = False
End If
End Sub
Private Sub cmdReceive_Click()
If blnReceiveFlag Then
If Not blnAutoSendFlag And Not blnReceiveFlag Then
frmMain.ctrMSComm.PortOpen = False
End If
frmMain.cmdReceive.Caption = "开始接收"
Else
If Not frmMain.ctrMSComm.PortOpen Then
frmMain.ctrMSComm.CommPort = intPort
frmMain.ctrMSComm.Settings = strSet
frmMain.ctrMSComm.PortOpen = True
End If
frmMain.ctrMSComm.InputLen = 0
frmMain.ctrMSComm.InputMode = 0
frmMain.ctrMSComm.InBufferCount = 0
frmMain.ctrMSComm.RThreshold = 10
frmMain.cmdReceive.Caption = "停止接收"
End If
blnReceiveFlag = Not blnReceiveFlag
End Sub
因长度超10000字,请另行提问给于补充.
'如果不是硬件的枣拍问题饥氏，就好处理了'定义委托然后在事件中处理（不需要延时）
Delegate Sub SetTextCallback(ByVal InputString As String)
Private Sub ShowString(ByVal comData As String)
txt_Rect.Text += comData '凳肢羡将收到的数据入接收文字框中
txt_Rect.SelectionStart = txt_Rect.Text.Length
txt_Rect.ScrollToCaret()
End Sub
Private Sub SerialPort1_DataReceived(ByVal sender As Object, ByVal e As System.IO.Ports.SerialDataReceivedEventArgs) Handles SerialPort1.DataReceived
Dim inData As String = SerialPort1.ReadExisting
Dim d As New SetTextCallback(AddressOf ShowString)
BeginInvoke(d, inData)
End Sub
欢迎分享，转载请注明来源：内存溢出
微信扫一扫
支付宝扫一扫
评论列表（0条）