標準模塊:
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字,請另行提問給於補充.