CRC Encoding VBA code for use with PromptPayQR

GetCRCModule.bas

Option Explicit
 
Public Function Crc6(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 6, True, &H6B&
 
  crc = 63
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (crc \ 256)
    Next i
  Crc6 = crc Xor 63
End Function

Public Function Crc16(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, True, &H8005&
  
  crc = 0
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (crc \ 256)
    Next i
  Crc16 = crc
End Function

Public Function Crc16_ModBus(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, True, &H8005&
  
  crc = &HFFFF&
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (crc \ 256)
    Next i
  Crc16_ModBus = crc
End Function

Public Function Crc16_USB(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, True, &H8005&
  
  crc = &HFFFF&
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (crc \ 256)
    Next i
  Crc16_USB = crc Xor &HFFFF&
End Function

Public Function Crc16_CCITT(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, False, &H1021&
  
  crc = &HFFFF&
    For i = LBound(b) To UBound(b)
      crc = (crcTab(((crc \ 256) Xor b(i)) And &HFF&) Xor (crc * 256)) And &HFFFF&
    Next i
  Crc16_CCITT = crc
End Function

Public Function Crc16_CCITT_XModem(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, False, &H1021&
  
  crc = 0
    For i = LBound(b) To UBound(b)
      crc = (crcTab(((crc \ 256) Xor b(i)) And &HFF&) Xor (crc * 256)) And &HFFFF&
    Next i
  Crc16_CCITT_XModem = crc
End Function

Public Function Crc16_CCITT_Kermit(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 16, True, &H1021&
  
  crc = 0
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (crc \ 256)
    Next i
  Crc16_CCITT_Kermit = crc \ 256 + 256 * (crc And &HFF&) 'Byte-Swap
End Function

Public Function Crc32(b() As Byte) As Long
Dim i As Long, crc As Long: Static crcTab(0 To 255) As Long
  If crcTab(1) = 0 Then CreateLookupTable crcTab, 32, True, &H4C11DB7
  
  crc = &HFFFFFFFF
    For i = LBound(b) To UBound(b)
      crc = crcTab((crc Xor b(i)) And &HFF&) Xor (((crc And &HFFFFFF00) \ &H100) And &HFFFFFF)
    Next i
  Crc32 = crc Xor &HFFFFFFFF
End Function

'-------------- Helper-Functions for Lookup-Table-Generation ----------------------

Private Sub CreateLookupTable(crcTab() As Long, ByVal BitLen As Long, ByVal Reflected As Boolean, ByVal Poly As Long)
Dim r As Long, i As Long, v As Long, BM As Long
  If BitLen = 32 Then BM = &H80000000 Else BM = 2 ^ (BitLen - 1)
  
  For v = 0 To UBound(crcTab)
    r = v
    If Reflected Then r = Reflect(v, IIf(BitLen < 8, BitLen, 8))
    If BitLen > 8 Then r = SHL(r, BitLen - 8)
 
    For i = 0 To IIf(BitLen < 8, BitLen, 8) - 1
      If r And BM Then
        r = SHL(r, 1) Xor Poly
      Else
        r = SHL(r, 1)
      End If
    Next
    
    If Reflected Then r = Reflect(r, BitLen)
    
    If BitLen = 32 Then
      crcTab(v) = r
    Else
      crcTab(v) = r And CLng(2 ^ BitLen - 1)
    End If
  Next v
End Sub

Private Function Reflect(ByVal v As Long, ByVal bits As Long) As Long
Dim i As Long, m As Long
  Reflect = v
  For i = 0 To bits - 1
    If (bits - i - 1) = 31 Then m = &H80000000 Else m = 2 ^ (bits - i - 1)
    Reflect = IIf(v And 1, Reflect Or m, Reflect And Not m)
    v = SHR(v, 1)
  Next i
End Function
 
Private Function SHL(ByVal Value As Long, ByVal bits As Long) As Long
Dim m As Long
  If bits = 0 Then SHL = Value: Exit Function
  m = 2 ^ (31 - bits)
  SHL = (Value And (m - 1)) * 2 ^ bits Or IIf(Value And m, &H80000000, 0)
End Function

Private Static Function SHR(ByVal Value As Long, ByVal bits As Long) As Long
  If Value > 0 Then SHR = Value \ 2 ^ bits: Exit Function
  SHR = ((Value And Not &H80000000) \ 2 ^ bits) Or 2 ^ (31 - bits)
End Function

Function GetCRC(tInput, Optional CRCType As String = "CRC16_CCITT")
'GetCRC by Pongsathorn Sraouthai BE2561
'CRCType Text, Default is "CRC16_CCITT"
'CRC6, CRC16, CRC16_MODBUS, CRC16_USB, CRC16_CCITT, CRC16_CCITT_XMODEM, CRC16_CCITT_KERMIT, CRC32

Dim b() As Byte
b = StrConv(tInput, vbFromUnicode)
Select Case CRCType
    Case "CRC6"
        GetCRC = Hex(Crc6(b))
    Case "CRC16"
        GetCRC = Hex(Crc16(b))
    Case "CRC16_MODBUS"
        GetCRC = Hex(Crc16_ModBus(b))
    Case "CRC16_USB"
        GetCRC = Hex(Crc16_USB(b))
    Case "CRC16_CCITT"
        GetCRC = Hex(Crc16_CCITT(b))
    Case "CRC16_CCITT_XMODEM"
        GetCRC = Hex(Crc16_CCITT_XModem(b))
    Case "CRC16_CCITT_KERMIT"
        GetCRC = Hex(Crc16_CCITT_Kermit(b))
    Case "CRC32"
        GetCRC = Hex(Crc32(b))
    Case Else
        Exit Function
End Select
End Function