parity.bas

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

Attribute VB_Name = "Parity"
Option Explicit
'depend on ByteProcess.bas

Public Const CHK_NONE = 0
Public Const CHK_XOR = 1
Public Const CHK_ADD = 2
Public Const CHK_CRC = 3
Public Const CHK_BCS = 4

Public Const ADD_NONE = 0
Public Const ADD_CR = 1
Public Const ADD_CRLF = 2

Public Function xorStrValue(ByVal strHexData As String) As String
  Dim I As Integer
  Dim xorTmp As Byte
  Dim vBuffer As Variant
  Dim lB As Integer
  Dim uB As Integer
    
  vBuffer = HexCharsToVariant(strHexData)
  lB = LBound(vBuffer)
  uB = UBound(vBuffer)
    
  xorTmp = 0
    
  For I = lB To uB
    xorTmp = xorTmp Xor vBuffer(I)
  Next I
    
  xorStrValue = ByteToTwoHexChars(xorTmp)
End Function

Public Function CheckXorStrValue(ByVal strHexData As String) As Boolean
  Dim strResult As String
  Dim strTmp As String
  Dim strParity As String
  
  If strHexData = "" Then
    CheckXorStrValue = False
    Exit Function
  End If
  
  strResult = Mid(strHexData, Len(strHexData) - 1)
  strTmp = Mid(strHexData, 1, Len(strHexData) - 2)
  strParity = xorStrValue(strTmp)
  If strResult = strParity Then
    CheckXorStrValue = True
  Else
    CheckXorStrValue = False
  End If
End Function

Public Function addStrValue(ByVal strHexData As String) As String
  Dim I As Integer
  Dim addTmp As Integer
  Dim vBuffer As Variant
  Dim lB As Integer
  Dim uB As Integer
    
  vBuffer = HexCharsToVariant(strHexData)
  lB = LBound(vBuffer)
  uB = UBound(vBuffer)
    
  addTmp = 0
    
  For I = lB To uB
    addTmp = (addTmp + vBuffer(I)) Mod 256
  Next I
    
  addStrValue = ByteToTwoHexChars(addTmp)
End Function

Public Function CheckAddStrValue(ByVal strHexData As String) As Boolean
    Dim strResult As String
    Dim strTmp As String
    Dim strParity As String
    
    If strHexData = "" Then
        CheckAddStrValue = False
        Exit Function
    End If
    
    strResult = Mid(strHexData, Len(strHexData) - 1)
    strTmp = Mid(strHexData, 1, Len(strHexData) - 2)
    strParity = addStrValue(strTmp)
    If strResult = strParity Then
        CheckAddStrValue = True
    Else
        CheckAddStrValue = False
    End If
End Function

Public Function crcStrValue(ByVal CrcSeed As String, ByVal strHexData As String) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                      '
'   Input:         FF 03 FC 01 00 16                   '
'   If CrcSeed= 0xFFFF, Then                           '
'        crcStrValue = B04A (the lower is at first)    '
'                                                      '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim I As Integer
  Dim J As Integer
  Dim hCrcEnd As Byte
  Dim lCrcEnd As Byte
  Dim hCrcConst As Byte
  Dim lCrcConst As Byte
  Dim uBN As Integer
  Dim lBN As Integer
  Dim vBuffer As Variant
    
  vBuffer = HexCharsToVariant(strHexData)
  uBN = UBound(vBuffer)
  lBN = LBound(vBuffer)
   
  hCrcEnd = TwoHexCharsToByte(Mid(CrcSeed, 1, 2))
  lCrcEnd = TwoHexCharsToByte(Mid(CrcSeed, 3, 2))
  hCrcConst = &HA0
  lCrcConst = 1
    
  For I = lBN To uBN
    lCrcEnd = lCrcEnd Xor vBuffer(I)
    For J = 0 To 7
      If lCrcEnd Mod 2 <> 0 Then
        lCrcEnd = lCrcEnd \ 2
        If hCrcEnd Mod 2 <> 0 Then lCrcEnd = lCrcEnd Or &H80
        hCrcEnd = hCrcEnd \ 2
        lCrcEnd = lCrcEnd Xor lCrcConst
        hCrcEnd = hCrcEnd Xor hCrcConst
      Else
        lCrcEnd = lCrcEnd \ 2
        If hCrcEnd Mod 2 <> 0 Then lCrcEnd = lCrcEnd Or &H80
        hCrcEnd = hCrcEnd \ 2
      End If
    Next J
  Next I
    
  crcStrValue = ByteToTwoHexChars(lCrcEnd) + ByteToTwoHexChars(hCrcEnd)
End Function

Public Function CheckCrcStrValue(ByVal strHexData As String) As Boolean
  Dim strResult As String
  Dim strTmp As String
  Dim strParity As String
  
  If strHexData = "" Then
    CheckCrcStrValue = False
    Exit Function
  End If
  
  strResult = Mid(strHexData, Len(strHexData) - 3)
  strTmp = Mid(strHexData, 1, Len(strHexData) - 4)
  strParity = crcStrValue("FFFF", strTmp)
  If strResult = strParity Then
    CheckCrcStrValue = True
  Else
    CheckCrcStrValue = False
  End If
End Function

Public Function addStrBCSValue(ByVal strHexData As String) As String
  'This is for 16 bits TCP/IP checksum.
  
  Dim nStrLength As Integer
  Dim vBuffer As Variant
  Dim lB As Integer
  Dim uB As Integer
  Dim nWords As Integer
  Dim I As Integer
  Dim sTmp As Single
  Dim sSum As Single
  Dim lResult As Long
    
  nStrLength = Len(strHexData)
  If nStrLength Mod 4 <> 0 Then
    strHexData = Mid(strHexData, 1, nStrLength - 2) + "00" + Mid(strHexData, nStrLength - 1, 2)
  End If
  
  vBuffer = HexCharsToVariant(strHexData)
  lB = LBound(vBuffer)
  uB = UBound(vBuffer)
  nWords = (uB - lB + 1) / 2
  sTmp = 0
    
  For I = 0 To nWords - 1
    sTmp = sTmp + vBuffer(lB + I * 2) * 256 + vBuffer(lB + I * 2 + 1)
  Next I
  
  sSum = (sTmp And &HFFFF)                               'low word
  sSum = sSum + (sTmp And &HFFFF0000) / 256 / 256        'high word shift right 16 bits
  sSum = sSum And &HFFFF
  lResult = sSum
  lResult = Not lResult
  
  addStrBCSValue = TwoBytesToHexChars(lResult)
End Function

Public Function CheckAddStrBCSValue(ByVal strHexData As String) As Boolean
  Dim strResult As String
  Dim strTmp As String
  Dim strParity As String
  
  If strHexData = "" Then
    CheckAddStrBCSValue = False
    Exit Function
  End If
  
  strResult = Mid(strHexData, Len(strHexData) - 3)
  strTmp = Mid(strHexData, 1, Len(strHexData) - 4)
  strParity = addStrBCSValue(strTmp)
  If strResult = strParity Then
    CheckAddStrBCSValue = True
  Else
    CheckAddStrBCSValue = False
  End If
End Function

Public Function AddEndMark(ByVal strHexData As String, nEndMark As Integer) As String
    Dim strTmp As String
    
    strTmp = GetEvenUCaseString(strHexData)
    
    Select Case nEndMark
        Case ADD_NONE
            AddEndMark = strTmp
        Case ADD_CR
            AddEndMark = strTmp + "0D"
        Case ADD_CRLF
            AddEndMark = strTmp + "0D0A"
    End Select
End Function

Public Function CheckEnd(ByVal strHexData As String, nEndMark As Integer) As Boolean
    Dim nlen As Integer
    Dim strTmp As String
    
    strTmp = UCase(strHexData)
    nlen = Len(strTmp)
    
    Select Case nEndMark
        Case ADD_CR
            If Mid(strTmp, nlen - 1) = "0D" Then CheckEnd = True
        Case ADD_CRLF
            If Mid(strTmp, nlen - 3) = "0D0A" Then CheckEnd = True
        Case ADD_NONE
            CheckEnd = True
    End Select
End Function

Public Function CheckParity(ByVal strHexData As String, nParity As Integer) As Boolean
    Select Case nParity
        Case CHK_NONE
            CheckParity = True
        Case CHK_XOR
            CheckParity = CheckXorStrValue(strHexData)
        Case CHK_ADD
            CheckParity = CheckAddStrValue(strHexData)
        Case CHK_CRC
            CheckParity = CheckCrcStrValue(strHexData)
        Case CHK_BCS
            CheckParity = CheckAddStrBCSValue(strHexData)
    End Select
End Function

Public Function GetFullPackage(ByVal strHexData As String, nParity As Integer, nEndMark As Integer) As String
    Dim strTmp As String
    Dim strPackage As String
    
    strTmp = GetEvenUCaseString(strHexData)
    Select Case nParity
        Case CHK_NONE
            strPackage = strTmp
        Case CHK_XOR
            strPackage = strTmp + xorStrValue(strTmp)
        Case CHK_ADD
            strPackage = strTmp + addStrValue(strTmp)
        Case CHK_CRC
            strPackage = strTmp + crcStrValue("FFFF", strTmp)
        Case CHK_BCS
            strPackage = strTmp + addStrBCSValue(strTmp)
    End Select
      
    GetFullPackage = AddEndMark(strPackage, nEndMark)
End Function

Public Function PickPurePackage(ByVal strHexData As String, nParity As Integer, nEndMark As Integer) As String
    Dim strTmp As String
    strTmp = UCase(strHexData)
    
    If CheckEnd(strTmp, nEndMark) = False Then GoTo EndMark
    Select Case nEndMark
        Case ADD_CR
            strTmp = Mid(strTmp, 1, Len(strTmp) - 2)
        Case ADD_CRLF
            strTmp = Mid(strTmp, 1, Len(strTmp) - 4)
    End Select
    
    If CheckParity(strTmp, nParity) = False Then GoTo EndMark
    Select Case nParity
        Case CHK_XOR, CHK_ADD
            strTmp = Mid(strTmp, 1, Len(strTmp) - 2)
        Case CHK_CRC, CHK_BCS
            strTmp = Mid(strTmp, 1, Len(strTmp) - 4)
    End Select
  
EndMark:
    PickPurePackage = strTmp
End Function

Public Function CheckPackage(ByVal strHexData As String, nParity As Integer, nEndMark As Integer) As Boolean
    Dim strTmp As String
    
    strTmp = UCase(strHexData)
    If CheckEnd(strTmp, nEndMark) = False Then Exit Function
    
    Select Case nEndMark
        Case ADD_CR
            strTmp = Mid(strTmp, 1, Len(strTmp) - 2)
        Case ADD_CRLF
            strTmp = Mid(strTmp, 1, Len(strTmp) - 4)
    End Select
    
    CheckPackage = CheckParity(strTmp, nParity)
End Function