发表于:2005/2/2 10:05:00
#0楼
本人使用VB编写了一个上位机于单片机的通讯程序,使用的是MODBUSRTU方式,带CRC校验的,发出去的数据单片机能收到,并且有回答,但是遇到asc码>127时显示的是3F(溢出),不知道该如何修改,这方面没学好-_-!!
部分代码如下:
Option Explicit
Dim sendlen, reclen
Private RTUCRC As String
Dim outbyte() As Byte
Dim hexchrgroup() As Byte
Dim n As Integer
Private Sub cboHexAscii_Click() '选择发送方式
If cboHexAscii.Text = "按ASCII码" Then
intOutMode = 0
Else
intOutMode = 1
End If
End Sub
Private Sub chkAscii_Click()
If chkAscii.Value = 1 Then
intAsciiChk = 1
Else
intAsciiChk = 0
End If
End Sub
Private Sub chkHex_Click()
If chkHex.Value = 0 Then
intHexChk = 0
Else
intHexChk = 1
End If
End Sub
Private Sub Manual_Click() '手动发送选择
If auto.Value = True Then
ctrTimer.Enabled = False
cmdPortOpen.Enabled = False
Else
ctrTimer.Enabled = True
cmdPortOpen.Enabled = True
End If
End Sub
Private Sub auto_Click() '自动发送选择
If ctrMSComm.PortOpen = False Then
MsgBox "串口未打开", , "错误信息"
End If
If ctrMSComm.PortOpen = True Then
If auto.Value = True Then
ctrTimer.Enabled = True
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = False
Else
ctrTimer.Enabled = False
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = True
End If
End If
Call RTUcheck
Call Hexsent
End Sub
Private Sub cmdExit_Click() '退出
Unload Me
End Sub
Private Sub cmdPortOpen_Click() '串口打开
On Error Resume Next
If ctrMSComm.PortOpen = False Then
ctrMSComm.PortOpen = True
Else
ctrMSComm.PortOpen = False
End If
If ctrMSComm.PortOpen Then '打开关闭按钮显示文字及combo1使能
cmdPortOpen.Caption = "关闭串口"
Combo1.Enabled = False
Else
cmdPortOpen.Caption = "打开串口"
Combo1.Enabled = True
End If
If Err Then '打开串口失败,则显示出错信息
MsgBox Error$, 48, "错误信息"
Exit Sub
End If
End Sub
Private Sub cmdStop_Click() '停止
If ctrMSComm.PortOpen = True Then
ctrMSComm.PortOpen = False
cmdPortOpen.Caption = "打开串口"
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = True
Combo1.Enabled = True
Else
MsgBox "串口未打开", , "错误信息"
End If
End Sub
'串口选择
Private Sub Combo1_Click()
ctrMSComm.CommPort = Combo1.ListIndex + 1
End Sub
'数据位改变
Private Sub Combo2_Click()
Call setting
End Sub
'波特率改变
Private Sub Combo3_Click()
Call setting
End Sub
'奇偶校验改变
Private Sub Combo4_Click()
Call setting
End Sub
'停止位改变
Private Sub Combo5_Click()
Call setting
End Sub
Private Sub setting() '通讯参数设置
ctrMSComm.Settings = CStr(Combo3.Text) & "," & CStr(Combo4.Text) & "," & CStr(Combo2.Text) & "," & CStr(Combo5.Text)
End Sub
Private Sub cmdClear_Click() '清除
txtReceive.Text = ""
Stxt.Text = ""
Dim bytTemp(0) As Byte
ReDim bytReceiveByte(0)
intReceiveLen = 0
Call InputManage(bytTemp, 0)
Call GetDisplayText
End Sub
Private Sub cmdManualSend_Click() '手动发送
Call ctrTimer_Timer
Call RTUcheck
Call Hexsent
End Sub
Private Sub cmdReceive_Click() '接收
If blnReceiveFlag Then
If Not blnAutoSendFlag And Not blnReceiveFlag Then
ctrMSComm.PortOpen = False
End If
cmdReceive.Caption = "开始接收"
Else
ctrMSComm.InputLen = 0
ctrMSComm.InputMode = 0
ctrMSComm.InBufferCount = 0
ctrMSComm.RThreshold = 1
cmdReceive.Caption = "停止接收"
End If
blnReceiveFlag = Not blnReceiveFlag
End Sub
Private Sub ctrMSComm_OnComm() '通讯
Dim bytInput() As Byte
Dim intInputLen As Integer
Dim hexchr As String, i As Integer, hexstring As String, j As Integer, answerVAL As String
'此处添加处理接收的代码
'ctrMSComm.InputMode = comInputModeBinary
hexstring = ctrMSComm.Input
i = Len(hexstring)
For j = 1 To i
hexchr = Mid(hexstring, j, 1)
If Hex(Asc(hexchr)) < 16 Then '如果hexchr(asc(chr)>128 溢出 为3F
txtReceive.Text = txtReceive.Text & "0" & Hex(Asc(hexchr)) & " "
Else
txtReceive.Text = txtReceive.Text & Hex(Asc(hexchr)) & " "
End If
'txtReceive.Text = txtReceive.Text & ctrMSComm.Input & CStr(Chr(13)) & CStr(Chr(10))
Next j
Call InputManage(bytInput, intInputLen)
Call GetDisplayText
txtReceive.Text = txtReceive.Text & CStr(Chr(13)) & CStr(Chr(10))
If Not blnAutoSendFlag And Not blnReceiveFlag Then
ctrMSComm.PortOpen = False
End If
End Sub
Private Sub time_Change() '发送时间间隔调整输入
Dim number As String
Dim num As Integer
Dim numcyc As Integer
num = Len(time.Text)
For numcyc = 1 To num
number = Mid(time.Text, numcyc, 1)
Select Case InStr("0123456789", number)
Case 0
MsgBox "输入时间间隔错误,请重新输入", , "错误信息"
Exit Sub
End Select
Next
ctrTimer.Interval = time.Text
End Sub
Private Sub ctrTimer_Timer() '自动发送定时
If ctrMSComm.PortOpen Then
Dim longth As Integer
strSendText = txtSend.Text
If intOutMode = 0 Then
ctrMSComm.Output = txtSend.Text
Else
longth = strHexToByteArray(strSendText, bytSendByte())
If longth > 0 Then
ctrMSComm.Output = bytSendByte
End If
End If
Call Hexsent
Call RTUcheck
End If
End Sub
Private Sub ctrTimer2_Timer() '状态刷新定时器
StatusBar.Panels(1).Text = "串口选择:" & CStr(Combo1.Text)
StatusBar.Panels(2).Text = "串口设置:" & CStr(ctrMSComm.Settings)
StatusBar.Panels(3).Text = "时间间隔:" & CStr(time.Text)
End Sub
'*****************************************
'初始化
'*****************************************
Private Sub Form_Load()
'设置默认发送接收关闭状态
blnAutoSendFlag = False
blnReceiveFlag = False
ctrMSComm.InBufferCount = 0
ctrMSComm.OutBufferCount = 0
'接收初始化
intReceiveLen = 0
'默认发送方式为ASCII
intOutMode = 1
intHexChk = 1
chkAscii.Value = intAsciiChk
chkHex.Value = intHexChk
'显示初始化
Call cmdClear_Click
'初始化串行口
Dim d%
For d = 1 To 6
Combo1.AddItem ("COM" & CStr(d))
Next
Combo1.ListIndex = 1
Combo2.AddItem "6"
Combo2.AddItem "7"
Combo2.AddItem "8"
Combo2.ListIndex = 2
Combo3.AddItem "1200"
Combo3.AddItem "2400"
Combo3.AddItem "4800"
Combo3.AddItem "9600"
Combo3.AddItem "19200"
Combo3.AddItem "38400"
Combo3.AddItem "57600"
Combo3.AddItem "115200"
Combo3.ListIndex = 6
Combo4.AddItem "n"
Combo4.AddItem "o"
Combo4.AddItem "e"
Combo4.AddItem "m"
Combo4.AddItem "s"
Combo4.ListIndex = 0
Combo5.AddItem "1"
Combo5.AddItem "2"
Combo5.ListIndex = 0
txtSend.Text = "030300000000"
time.Text = 1000
Manual.Value = True
If ctrMSComm.PortOpen = False Then
cmdPortOpen.Caption = "打开串口"
Else
cmdPortOpen.Caption = "关闭串口"
End If
End Sub
Private Sub RTUcheck() 'RTU校验
Dim a As Integer
Dim CRC() As Byte
Dim d() As Byte
Dim RECstring As String
Dim b As Integer, chrlength As Integer, temp As String
RECstring = txtSend.Text
chrlength = Len(RECstring)
a = chrlength / 2 - 1
ReDim d(a) As Byte
For b = 0 To chrlength / 2 - 1
temp = Mid(RECstring, b * 2 + 1, 2)
d(b) = Val("&H" & temp)
Next
RTUCRC = CRC16(d) '调用CRC16计算函数, CRC(0)为高位, CRC(1)为低位
Stxt.Text = txtSend + RTUCRC
End Sub
Private Sub Hexsent() '发送子程序
Stxt.Text = txtSend + RTUCRC
Dim hexchrlen%, hexchr As String, hexcyc%, hexmid As String
Dim i, j As Integer
hexchrlen = Len(Stxt)
For hexcyc = 1 To hexchrlen 'hexcyc=1to16 检查发送的数值是否合适
hexchr = Mid(Stxt, hexcyc, 1)
If InStr("0123456789ABCDEFabcdef", hexchr) = 0 Then
MsgBox "无效的数值,请重新输入", , "错误信息"
Exit Sub
End If
Next
ReDim outbyte(1 To hexchrlen / 2) As Byte
For i = 1 To hexchrlen / 2
hexcyc = 2 * i - 1
hexchr = Mid(Stxt, hexcyc, 2)
hexmid = CStr(hexchr)
outbyte(i) = Val("&H" + hexmid)
Next i
ctrMSComm.Output = outbyte()
End Sub
Private Function DecToHex(nNum As Integer) As String
Dim str1, str2 As String
Dim num1, num2 As Integer
num1 = nNum \ 16 '除数
If num1 >= 10 Then
str1 = Chr(65 + num1 - 10) '显示A TO F
Else
str1 = str(num1)
End If
num2 = nNum Mod 16 '余数
If num2 >= 10 Then
str2 = Chr(65 + num2 - 10) '显示A TO F
Else
str2 = str(num2)
End If
DecToHex = "0x" & Right(str1, 1) & Right(str2, 1)
End Function
Private Function CRC16(data() As Byte) As String 'CRC校验程序
Dim CRC16Lo As Byte, CRC16Hi As Byte 'CRC寄存器
Dim CL As Byte, CH As Byte '多项式码&HA001
Dim CRCLo As String, CRCHi As String
Dim SaveHi As Byte, SaveLo As Byte
Dim i As Integer
Dim Flag As Integer
CRC16Lo = &HFF
CRC16Hi = &HFF
CL = &H1
CH = &HA0
For i = 0 To UBound(data)
CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
For Flag = 0 To 7
SaveHi = CRC16Hi
SaveLo = CRC16Lo
CRC16Hi = CRC16Hi \ 2 '高位右移一位
CRC16Lo = CRC16Lo \ 2 '低位右移一位
If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
CRC16Lo = CRC16Lo Or &H80 '则低位字节右移后前面补1
End If '否则自动补0
If ((SaveLo And &H1) = &H1) Then '如果LSB为1,则与多项式码进行异或
CRC16Hi = CRC16Hi Xor CH
CRC16Lo = CRC16Lo Xor CL
End If
Next Flag
Next i
If Len(Hex(CRC16Hi)) = 1 Then
CRCHi = "0" + Hex(CRC16Hi)
Else
CRCHi = Hex(CRC16Hi)
End If
If Len(Hex(CRC16Lo)) = 1 Then
CRCLo = "0" + Hex(CRC16Lo)
Else
CRCLo = Hex(CRC16Lo)
End If
CRC16 = CRCLo + CRCHi
End Function
'**********************************
'字符表示的十六进制数转化为相应的整数 (16进制数--->10进制)
'错误则返回 -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
'**********************************
'字符串表示的十六进制数据转化为相应的字节串 (16进制--->文本模式)
'返回转化后的字节数
'**********************************
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 '计数
strText = "" '设初值
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
部分代码如下:
Option Explicit
Dim sendlen, reclen
Private RTUCRC As String
Dim outbyte() As Byte
Dim hexchrgroup() As Byte
Dim n As Integer
Private Sub cboHexAscii_Click() '选择发送方式
If cboHexAscii.Text = "按ASCII码" Then
intOutMode = 0
Else
intOutMode = 1
End If
End Sub
Private Sub chkAscii_Click()
If chkAscii.Value = 1 Then
intAsciiChk = 1
Else
intAsciiChk = 0
End If
End Sub
Private Sub chkHex_Click()
If chkHex.Value = 0 Then
intHexChk = 0
Else
intHexChk = 1
End If
End Sub
Private Sub Manual_Click() '手动发送选择
If auto.Value = True Then
ctrTimer.Enabled = False
cmdPortOpen.Enabled = False
Else
ctrTimer.Enabled = True
cmdPortOpen.Enabled = True
End If
End Sub
Private Sub auto_Click() '自动发送选择
If ctrMSComm.PortOpen = False Then
MsgBox "串口未打开", , "错误信息"
End If
If ctrMSComm.PortOpen = True Then
If auto.Value = True Then
ctrTimer.Enabled = True
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = False
Else
ctrTimer.Enabled = False
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = True
End If
End If
Call RTUcheck
Call Hexsent
End Sub
Private Sub cmdExit_Click() '退出
Unload Me
End Sub
Private Sub cmdPortOpen_Click() '串口打开
On Error Resume Next
If ctrMSComm.PortOpen = False Then
ctrMSComm.PortOpen = True
Else
ctrMSComm.PortOpen = False
End If
If ctrMSComm.PortOpen Then '打开关闭按钮显示文字及combo1使能
cmdPortOpen.Caption = "关闭串口"
Combo1.Enabled = False
Else
cmdPortOpen.Caption = "打开串口"
Combo1.Enabled = True
End If
If Err Then '打开串口失败,则显示出错信息
MsgBox Error$, 48, "错误信息"
Exit Sub
End If
End Sub
Private Sub cmdStop_Click() '停止
If ctrMSComm.PortOpen = True Then
ctrMSComm.PortOpen = False
cmdPortOpen.Caption = "打开串口"
cmdPortOpen.Enabled = True
cmdManualSend.Enabled = True
Combo1.Enabled = True
Else
MsgBox "串口未打开", , "错误信息"
End If
End Sub
'串口选择
Private Sub Combo1_Click()
ctrMSComm.CommPort = Combo1.ListIndex + 1
End Sub
'数据位改变
Private Sub Combo2_Click()
Call setting
End Sub
'波特率改变
Private Sub Combo3_Click()
Call setting
End Sub
'奇偶校验改变
Private Sub Combo4_Click()
Call setting
End Sub
'停止位改变
Private Sub Combo5_Click()
Call setting
End Sub
Private Sub setting() '通讯参数设置
ctrMSComm.Settings = CStr(Combo3.Text) & "," & CStr(Combo4.Text) & "," & CStr(Combo2.Text) & "," & CStr(Combo5.Text)
End Sub
Private Sub cmdClear_Click() '清除
txtReceive.Text = ""
Stxt.Text = ""
Dim bytTemp(0) As Byte
ReDim bytReceiveByte(0)
intReceiveLen = 0
Call InputManage(bytTemp, 0)
Call GetDisplayText
End Sub
Private Sub cmdManualSend_Click() '手动发送
Call ctrTimer_Timer
Call RTUcheck
Call Hexsent
End Sub
Private Sub cmdReceive_Click() '接收
If blnReceiveFlag Then
If Not blnAutoSendFlag And Not blnReceiveFlag Then
ctrMSComm.PortOpen = False
End If
cmdReceive.Caption = "开始接收"
Else
ctrMSComm.InputLen = 0
ctrMSComm.InputMode = 0
ctrMSComm.InBufferCount = 0
ctrMSComm.RThreshold = 1
cmdReceive.Caption = "停止接收"
End If
blnReceiveFlag = Not blnReceiveFlag
End Sub
Private Sub ctrMSComm_OnComm() '通讯
Dim bytInput() As Byte
Dim intInputLen As Integer
Dim hexchr As String, i As Integer, hexstring As String, j As Integer, answerVAL As String
'此处添加处理接收的代码
'ctrMSComm.InputMode = comInputModeBinary
hexstring = ctrMSComm.Input
i = Len(hexstring)
For j = 1 To i
hexchr = Mid(hexstring, j, 1)
If Hex(Asc(hexchr)) < 16 Then '如果hexchr(asc(chr)>128 溢出 为3F
txtReceive.Text = txtReceive.Text & "0" & Hex(Asc(hexchr)) & " "
Else
txtReceive.Text = txtReceive.Text & Hex(Asc(hexchr)) & " "
End If
'txtReceive.Text = txtReceive.Text & ctrMSComm.Input & CStr(Chr(13)) & CStr(Chr(10))
Next j
Call InputManage(bytInput, intInputLen)
Call GetDisplayText
txtReceive.Text = txtReceive.Text & CStr(Chr(13)) & CStr(Chr(10))
If Not blnAutoSendFlag And Not blnReceiveFlag Then
ctrMSComm.PortOpen = False
End If
End Sub
Private Sub time_Change() '发送时间间隔调整输入
Dim number As String
Dim num As Integer
Dim numcyc As Integer
num = Len(time.Text)
For numcyc = 1 To num
number = Mid(time.Text, numcyc, 1)
Select Case InStr("0123456789", number)
Case 0
MsgBox "输入时间间隔错误,请重新输入", , "错误信息"
Exit Sub
End Select
Next
ctrTimer.Interval = time.Text
End Sub
Private Sub ctrTimer_Timer() '自动发送定时
If ctrMSComm.PortOpen Then
Dim longth As Integer
strSendText = txtSend.Text
If intOutMode = 0 Then
ctrMSComm.Output = txtSend.Text
Else
longth = strHexToByteArray(strSendText, bytSendByte())
If longth > 0 Then
ctrMSComm.Output = bytSendByte
End If
End If
Call Hexsent
Call RTUcheck
End If
End Sub
Private Sub ctrTimer2_Timer() '状态刷新定时器
StatusBar.Panels(1).Text = "串口选择:" & CStr(Combo1.Text)
StatusBar.Panels(2).Text = "串口设置:" & CStr(ctrMSComm.Settings)
StatusBar.Panels(3).Text = "时间间隔:" & CStr(time.Text)
End Sub
'*****************************************
'初始化
'*****************************************
Private Sub Form_Load()
'设置默认发送接收关闭状态
blnAutoSendFlag = False
blnReceiveFlag = False
ctrMSComm.InBufferCount = 0
ctrMSComm.OutBufferCount = 0
'接收初始化
intReceiveLen = 0
'默认发送方式为ASCII
intOutMode = 1
intHexChk = 1
chkAscii.Value = intAsciiChk
chkHex.Value = intHexChk
'显示初始化
Call cmdClear_Click
'初始化串行口
Dim d%
For d = 1 To 6
Combo1.AddItem ("COM" & CStr(d))
Next
Combo1.ListIndex = 1
Combo2.AddItem "6"
Combo2.AddItem "7"
Combo2.AddItem "8"
Combo2.ListIndex = 2
Combo3.AddItem "1200"
Combo3.AddItem "2400"
Combo3.AddItem "4800"
Combo3.AddItem "9600"
Combo3.AddItem "19200"
Combo3.AddItem "38400"
Combo3.AddItem "57600"
Combo3.AddItem "115200"
Combo3.ListIndex = 6
Combo4.AddItem "n"
Combo4.AddItem "o"
Combo4.AddItem "e"
Combo4.AddItem "m"
Combo4.AddItem "s"
Combo4.ListIndex = 0
Combo5.AddItem "1"
Combo5.AddItem "2"
Combo5.ListIndex = 0
txtSend.Text = "030300000000"
time.Text = 1000
Manual.Value = True
If ctrMSComm.PortOpen = False Then
cmdPortOpen.Caption = "打开串口"
Else
cmdPortOpen.Caption = "关闭串口"
End If
End Sub
Private Sub RTUcheck() 'RTU校验
Dim a As Integer
Dim CRC() As Byte
Dim d() As Byte
Dim RECstring As String
Dim b As Integer, chrlength As Integer, temp As String
RECstring = txtSend.Text
chrlength = Len(RECstring)
a = chrlength / 2 - 1
ReDim d(a) As Byte
For b = 0 To chrlength / 2 - 1
temp = Mid(RECstring, b * 2 + 1, 2)
d(b) = Val("&H" & temp)
Next
RTUCRC = CRC16(d) '调用CRC16计算函数, CRC(0)为高位, CRC(1)为低位
Stxt.Text = txtSend + RTUCRC
End Sub
Private Sub Hexsent() '发送子程序
Stxt.Text = txtSend + RTUCRC
Dim hexchrlen%, hexchr As String, hexcyc%, hexmid As String
Dim i, j As Integer
hexchrlen = Len(Stxt)
For hexcyc = 1 To hexchrlen 'hexcyc=1to16 检查发送的数值是否合适
hexchr = Mid(Stxt, hexcyc, 1)
If InStr("0123456789ABCDEFabcdef", hexchr) = 0 Then
MsgBox "无效的数值,请重新输入", , "错误信息"
Exit Sub
End If
Next
ReDim outbyte(1 To hexchrlen / 2) As Byte
For i = 1 To hexchrlen / 2
hexcyc = 2 * i - 1
hexchr = Mid(Stxt, hexcyc, 2)
hexmid = CStr(hexchr)
outbyte(i) = Val("&H" + hexmid)
Next i
ctrMSComm.Output = outbyte()
End Sub
Private Function DecToHex(nNum As Integer) As String
Dim str1, str2 As String
Dim num1, num2 As Integer
num1 = nNum \ 16 '除数
If num1 >= 10 Then
str1 = Chr(65 + num1 - 10) '显示A TO F
Else
str1 = str(num1)
End If
num2 = nNum Mod 16 '余数
If num2 >= 10 Then
str2 = Chr(65 + num2 - 10) '显示A TO F
Else
str2 = str(num2)
End If
DecToHex = "0x" & Right(str1, 1) & Right(str2, 1)
End Function
Private Function CRC16(data() As Byte) As String 'CRC校验程序
Dim CRC16Lo As Byte, CRC16Hi As Byte 'CRC寄存器
Dim CL As Byte, CH As Byte '多项式码&HA001
Dim CRCLo As String, CRCHi As String
Dim SaveHi As Byte, SaveLo As Byte
Dim i As Integer
Dim Flag As Integer
CRC16Lo = &HFF
CRC16Hi = &HFF
CL = &H1
CH = &HA0
For i = 0 To UBound(data)
CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
For Flag = 0 To 7
SaveHi = CRC16Hi
SaveLo = CRC16Lo
CRC16Hi = CRC16Hi \ 2 '高位右移一位
CRC16Lo = CRC16Lo \ 2 '低位右移一位
If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
CRC16Lo = CRC16Lo Or &H80 '则低位字节右移后前面补1
End If '否则自动补0
If ((SaveLo And &H1) = &H1) Then '如果LSB为1,则与多项式码进行异或
CRC16Hi = CRC16Hi Xor CH
CRC16Lo = CRC16Lo Xor CL
End If
Next Flag
Next i
If Len(Hex(CRC16Hi)) = 1 Then
CRCHi = "0" + Hex(CRC16Hi)
Else
CRCHi = Hex(CRC16Hi)
End If
If Len(Hex(CRC16Lo)) = 1 Then
CRCLo = "0" + Hex(CRC16Lo)
Else
CRCLo = Hex(CRC16Lo)
End If
CRC16 = CRCLo + CRCHi
End Function
'**********************************
'字符表示的十六进制数转化为相应的整数 (16进制数--->10进制)
'错误则返回 -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
'**********************************
'字符串表示的十六进制数据转化为相应的字节串 (16进制--->文本模式)
'返回转化后的字节数
'**********************************
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 '计数
strText = "" '设初值
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