checksummodule.bas

自己编写的

Attribute VB_Name = "checkSumModule"
Option Explicit

Public Function adjustHexString(hexString As String) As String
'此函数用来校正十六进制字符串 "3fA degk"->"3FADEGK"
'去掉空格，转换为大写，并不进行十六进制字符的验证
'曾劲松　2005/5/25
    Dim i, length As Integer
    Dim c, s As String
    
    length = Len(hexString)
    '去掉空格先
    For i = 1 To length
      c = Mid(hexString, i, 1)
      If c <> " " Then
        s = s + c
      End If
    Next i
    '转换为大写
    s = UCase(s)
    adjustHexString = s
End Function

Public Function isValidHexString(hexString As String) As Boolean
'本函数用来判断某字符串是否为合法的十六进制字符串
'本函数作以下验证：字符必须介于0-9,A-F,去掉空格后的字符数必须是偶数
'曾劲松　2005/5/25
    Dim i, length As Integer
    Dim c, s, a As String
    
    s = adjustHexString(hexString)
    
    length = Len(s)
    If length Mod 2 <> 0 Then
      isValidHexString = False
      Exit Function
    End If
    
    '判断每一个字符是否在范围之内
    For i = 1 To length
      c = Mid(s, i)
      a = Asc(c)
      If a < 48 Or a > 70 Then
        isValidHexString = False
        Exit Function
      Else
        If a > 57 And a < 65 Then
          isValidHexString = False
          Exit Function
        End If
      End If
    Next i
    isValidHexString = True
End Function

Public Function hexToDec(ByVal hexString As String) As Long
'本函数将十六进制字符串转换成整数
'在转换过程中发生错误则返回-1
'曾劲松　2005/5/25
    Dim i, v, length, r As Long
    Dim c, s As String
    
    On Error GoTo errorhandle
    
    If Not isValidHexString(hexString) Then
    '如果不是合法的十六进制字符串，则返回-1
      hexToDec = -1
      Exit Function
    End If
    
    r = 0
    hexString = adjustHexString(hexString)
    length = Len(hexString)
    
    For i = 1 To length
      c = Mid(hexString, i, 1)
      If Asc(c) <= 57 Then
      '是数字
        v = Asc(c) - 48
      Else
      '是字母
        v = Asc(c) - 65 + 10
      End If
      r = r + v * (16 ^ (length - i))
    Next
   hexToDec = r
   Exit Function
errorhandle:
  hexToDec = -1
  MsgBox "溢出！", vbCritical
  Exit Function
End Function



Public Function xor_sum(s As String) As String
'计算异或和  s="0E FF 09 44 23 40"
'返回将十六进制字符串的每个字节进行异或得的结果，如果传入的参数不是合法的字符串，则返回"error!"
'曾劲松 2005/5/25
  s = adjustHexString(s)
  If Not isValidHexString(s) Then
    xor_sum = "error!"
    Exit Function
  End If
  
  Dim i, length, r As Long
  Dim m As String
  length = Len(s)
  For i = 1 To length Step 2
    m = Mid(s, i, 2)
    If i = 1 Then
      r = hexToDec(m)
    Else
     r = r Xor hexToDec(m)
    End If
  Next
  
  s = Hex(r)
  If Len(s) = 1 Then
    s = "0" + s
  End If
  's = Right(s, 2) '最终结果必为两个字符，所以不必这句
  xor_sum = s
End Function

Public Function add_sum(ByVal s As String) As String
'计算异或和  s="0E FF 09 44 23 40"
'返回将十六进制字符串的每个字节进行相加得的结果，如果传入的参数不是合法的字符串，则返回"error!"
'曾劲松 2005/5/25
  s = adjustHexString(s)
  If Not isValidHexString(s) Then
    add_sum = "error!"
    Exit Function
  End If
  
  Dim i, length, r As Long
  Dim m As String
  length = Len(s)
  For i = 1 To length Step 2
    m = Mid(s, i, 2)
    If i = 1 Then
      r = hexToDec(m)
    Else
     r = r + hexToDec(m)
    End If
  Next
  
  s = Hex(r)
  If Len(s) = 1 Then
    s = "0" + s
  End If
  s = Right(s, 2) '最终结果必为两个字符，所以不必这句
  add_sum = s
End Function


Public Function yd2000_crc16(data As String) As String
  '在进行ＣＲＣ码计算时只用８位数据位，起始位及停止位，如有奇偶校验位的话也包括奇偶校验位，
  '都不参与ＣＲＣ码计算。
  'CRC-16码的计算步骤为
  '1.置16位寄存器为十六进制FFFF(即全为1)。称此寄存器为ＣＲＣ寄存器
  '2.把一个8位数据与１６位ＣＲＣ寄存器的低位相异或，把结果放入ＣＲＣ寄存器
  '3.将寄存器的内容右移一位（朝低位），用０填补最高位，检查最低位（移出位）。
  '4.如果最低位为０，重复第３步（再次移位）
  '  如果最低位为１：ＣＲＣ寄存器与多项式A001(1010 0000 0000 0001)进行异或
  '5.重复步骤3和4，直到右移８次，这样整个８位数据全部进行了处理
  '6.重复步骤2到步骤5，进行下一个８位的处理
  '7.最后得到的ＣＲＣ寄存器即为ＣＲＣ码，低字节在前，高字节在后。
  '--------------------------------摘自《YD2000　智能电力检测仪　使用手册 v1.2》P79

  '曾劲松　2005/6/6
  '错误则返回 Error 字符串

  data = adjustHexString(data)
  If Not isValidHexString(data) Then
    yd2000_crc16 = "Error."
    Exit Function
  End If

  Dim crc, crcLow As Long
  crc = &HFFFF
  crcLow = &HFF
  
  Dim i, abyte, count As Long
  i = 1
  
  Dim mid2char As String
  
  While i < Len(data)
    crcLow = LoByte(crc)    '取寄存器的低字节
    mid2char = Mid(data, i, 2)  '取数据的每一个字节
    'abyte = hexToDec(mid2char)  '转换为十进制
    abyte = Val("&H" + mid2char)    '转换成十进制，ＶＢ自带转换函数
    
    'crcLow = BitXOR(crcLow, abyte)  '将低字节与一个字节的数据异或
    crcLow = crcLow Xor abyte       'ＶＢ自带异或操作符
    
    crc = shl(HiByte(crc), 8) + crcLow  '将异或的结果放入寄存器的低字节中
    count = 0
    While count < 8     '循环8次
        If crc Mod 2 <> 0 Then  '最后一位是1
            crc = shr(crc, 1)   '右移一位
            'Debug.Print Hex(crc) + "  " + Str(count + 1)
            'crc = BitXOR(crc, &HA001)
            crc = crc Xor &HA001
            crc = LoWord(crc)   '异或后延伸了字长，会产生错误，所以这里要取低字！！
            'Debug.Print Hex(crc)
        Else    '最后一位是0
            crc = shr(crc, 1)   '直接移位
            'Debug.Print Hex(crc) + "  " + Str(count + 1)
        End If
        count = count + 1   '计数加一
    Wend
    i = i + 2       '取下一个字节
  Wend
  
  Dim hi, lo As String
  hi = Hex(HiByte(crc))
  lo = Hex(LoByte(crc))
  hi = IIf(Len(hi) < 2, "0" + hi, hi)
  lo = IIf(Len(lo) < 2, "0" + lo, lo)
  yd2000_crc16 = lo + " " + hi      '低位在前
  
End Function