byteprocess.bas

这是一本学习串口编程喝计算机监控的好书里面是用VB开发的源代码

Attribute VB_Name = "ByteProcess"
'Data Type: Integer%, Long&, Single!, Double#, Currency@, String$
'array start from 0 at default
Option Explicit
'no dependence
Public Const HEX_CHAR_SET = "0123456789ABCDEF"

Public Function ByteToTwoHexChars(ByVal iVal As Byte) As String
  'from 0x3d to "3D"
  Dim strtmp As String
    
  iVal = iVal And &HFF
  strtmp = Hex(iVal)
  If Len(strtmp) = 1 Then strtmp = "0" + strtmp
  ByteToTwoHexChars = Trim(strtmp)
End Function

Public Function TwoBytesToHexChars(ByVal iVal As Long) As String
  Dim nTmp As Long
  Dim strtmp As String
    
  iVal = iVal And &HFFFF
  nTmp = ((iVal And &HFF00) \ &H100) And &HFF
  strtmp = ByteToTwoHexChars(nTmp)
  nTmp = iVal And &HFF
  strtmp = strtmp + ByteToTwoHexChars(nTmp)
  TwoBytesToHexChars = Trim(strtmp)
End Function

Public Function HexCharToNum(ByVal cVal As String) As Byte
  Dim t1 As Integer
    
  If IsNull(cVal) Or cVal = "" Then
    'The hex char is null!
    cVal = "0"
  Else
    cVal = Mid(Trim(UCase(cVal)), 1, 1)
    If InStr(HEX_CHAR_SET, cVal) = 0 Then
      'The hex char is not in the right range!
      cVal = "0"
    End If
  End If
    
  t1 = Asc(cVal) - 48
  If t1 > 9 Then t1 = t1 - 7
    
  HexCharToNum = t1
End Function

Public Function TwoHexCharsToByte(ByVal strVal As String) As Byte
  Dim t1 As Integer
  Dim t2 As Integer
    
  strVal = Trim(strVal)
  If Len(strVal) = 1 Then strVal = "0" + strVal
    
  If strVal = "" Then
    'The hex chars is Null!
    TwoHexCharsToByte = 0
    Exit Function
  End If
  
  t1 = HexCharToNum(Mid(strVal, 1, 1))
  t2 = HexCharToNum(Mid(strVal, 2, 1))
  TwoHexCharsToByte = t1 * 16 + t2
End Function

Public Function HexCharsToVariant(ByVal strVal As String) As Variant
  Dim I As Integer
  Dim nLength As Integer
  Dim bTmp() As Byte
    
  If strVal = "" Then
    ReDim bTmp(0)
    bTmp(0) = 0
    HexCharsToVariant = bTmp
    Exit Function
  End If
  
  strVal = Trim(strVal)
  nLength = Len(strVal) \ 2 - 1
  ReDim bTmp(nLength)
    
  For I = 0 To nLength
    bTmp(I) = TwoHexCharsToByte((Mid(strVal, I * 2 + 1, 2)))
  Next I
    
  HexCharsToVariant = bTmp
End Function

Public Function VariantToHexChars(ByRef vBuffers As Variant) As String
  Dim nStart As Integer
  Dim nEnd As Integer
  Dim I As Integer
  
  nStart = LBound(vBuffers)
  nEnd = UBound(vBuffers)
  
  For I = nStart To nEnd
    VariantToHexChars = VariantToHexChars + ByteToTwoHexChars(vBuffers(I))
  Next I
End Function

Public Function StringToHexChars(ByVal strVal As String) As String
  'from "1" to "31"
  Dim HexChars As String
  Dim strtmp As String
  Dim I As Integer
    
  strVal = strVal

  For I = 0 To Len(strVal) - 1
    strtmp = Mid(strVal, I + 1, 1)
    If (AscW(strtmp) \ &H100 = 0) And AscW(strtmp) > 0 Then
      HexChars = HexChars + ByteToTwoHexChars(AscW(strtmp))
    Else
      HexChars = HexChars + TwoBytesToHexChars(AscW(strtmp))
    End If
  Next I
    
  StringToHexChars = HexChars
End Function

Public Function HexCharsToString(ByVal strVal As String) As String
  'from "31" to "1"
  Dim StringChars As String
  Dim I As Integer
  strVal = Trim(strVal)
    
  For I = 0 To Len(strVal) \ 2 - 1
    StringChars = StringChars + Chr(TwoHexCharsToByte(Mid(strVal, I * 2 + 1, 2)))
  Next I
    
  HexCharsToString = StringChars
End Function

Public Function GetEvenUCaseString(ByVal strtmp As String) As String
  'from "0d134" to "0D13"
  strtmp = Trim(strtmp)
  If strtmp = "" Then
    GetEvenUCaseString = ""
  Else
    GetEvenUCaseString = UCase(Mid(strtmp, 1, (Len(strtmp) \ 2) * 2))
  End If
End Function

Public Function BytesToSingleCharsA(ByRef bData() As Byte) As String
  'from 0x31,0x30 to "10", length is in bData(0)
  Dim strtmp As String
  Dim I As Integer
    
  For I = 0 To bData(0) - 1
    strtmp = strtmp + Chr(bData(LBound(bData) + I + 1))
  Next I
    
  BytesToSingleCharsA = Trim(strtmp)
End Function

Public Function BytesToSingleCharsB(ByRef bData() As Byte) As String
  'from 0x31,0x30 to "10", length is UBound(bData)-LBound(bData)+1
  Dim strtmp As String
  Dim I As Integer
    
  For I = 0 To UBound(bData) - LBound(bData)
    strtmp = strtmp + Chr(bData(LBound(bData) + I))
  Next I
    
  BytesToSingleCharsB = Trim(strtmp)
End Function

Public Function GetRandomByte(ByVal nFrom As Integer, nTo As Integer) As Byte
  If nFrom > nTo Or nFrom < 0 Or nTo < 0 Then
    'Error:  nFrom > nTo!
    GetRandomByte = 0
    Exit Function
  End If
      
  Randomize
  
  Do While True
    GetRandomByte = Int(0.5 + 255 * Rnd)
    If GetRandomByte >= nFrom And GetRandomByte <= nTo Then Exit Do
    DoEvents
  Loop
End Function

Public Function UnicodeCharsToString(ByVal strSource As String) As String
    'only for pure chinese
    Dim strtmp As String
    Dim nLen As Integer
    Dim I As Integer
    
    nLen = Len(strSource) \ 4
    If nLen = 0 Then Exit Function
    
    For I = 1 To nLen
        strtmp = Mid(strSource, (I - 1) * 4 + 1, 4)
        UnicodeCharsToString = UnicodeCharsToString + ChrW( _
                            TwoHexCharsToByte(Mid(strtmp, 1, 2)) * 256& + _
                            TwoHexCharsToByte(Mid(strtmp, 3, 2)))
    Next I
End Function

Public Function StringToUnicodeChars(ByVal strVal As String) As String
  'from "1" to "0031"
  Dim HexChars As String
  Dim strtmp As String
  Dim I As Integer
    
  strVal = strVal

  For I = 0 To Len(strVal) - 1
    strtmp = Mid(strVal, I + 1, 1)
    If (AscW(strtmp) \ &H100 = 0) And AscW(strtmp) > 0 Then
      HexChars = HexChars + "00" + ByteToTwoHexChars(AscW(strtmp))
    Else
      HexChars = HexChars + TwoBytesToHexChars(AscW(strtmp))
    End If
  Next I
    
  StringToUnicodeChars = HexChars
End Function

Public Function Encode_Unicode(ByVal strSource As String, ByVal strKey As String) As String
    Dim strSourceHex As String
    Dim strKeyHex As String
    Dim I As Integer
    Dim J As Integer
    Dim nSource As Integer
    Dim nKey As Integer
    Dim strData As String
    
    If strSource = "" Or strKey = "" Then Exit Function
    strSourceHex = StringToUnicodeChars(strSource)
    strKeyHex = StringToUnicodeChars(strKey)
    nSource = Len(strSourceHex) / 2
    nKey = Len(strKeyHex) / 2
    
    J = 1
    For I = 1 To nSource
        strData = strData + ByteToTwoHexChars(TwoHexCharsToByte(Mid(strSourceHex, (I - 1) * 2 + 1, 2)) Xor _
                                              TwoHexCharsToByte(Mid(strKeyHex, (J - 1) * 2 + 1, 2)))
        J = J + 1
        If J > nKey Then J = 1
    Next I
    
    Encode_Unicode = strData
End Function

Public Function Decode_Unicode(ByVal strSourceHex As String, ByVal strKey As String) As String
    Dim strKeyHex As String
    Dim I As Integer
    Dim J As Integer
    Dim nSource As Integer
    Dim nKey As Integer
    Dim strData As String
    
    If strSourceHex = "" Or strKey = "" Then Exit Function
    strKeyHex = StringToUnicodeChars(strKey)
    nSource = Len(strSourceHex) / 2
    nKey = Len(strKeyHex) / 2
    
    J = 1
    For I = 1 To nSource
        strData = strData + ByteToTwoHexChars(TwoHexCharsToByte(Mid(strSourceHex, (I - 1) * 2 + 1, 2)) Xor _
                                              TwoHexCharsToByte(Mid(strKeyHex, (J - 1) * 2 + 1, 2)))
        J = J + 1
        If J > nKey Then J = 1
    Next I
    
    Decode_Unicode = UnicodeCharsToString(strData)
End Function