Attribute VB_Name = "basCRC24"
Option Explicit

' basCRC24: Calculates CRC-24 checksum for a given message string
' Version 1. Published 4 June 2003.
' Updated 17 June 2020 - changed license on this code to MIT.

' ******************************* LICENSE ***********************************
' * Copyright (C) 2003-20 David Ireland, DI Management Services Pty Limited.
' * All rights reserved. <www.di-mgt.com.au> <www.cryptosys.net>
' * The code in this module is licensed under the terms of the MIT license.  
' * For a copy, see <http://opensource.org/licenses/MIT>
' ***************************************************************************

' Please forward comments or bug reports to https://di-mgt.com.au/contact


' FUNCTIONS:-
' Public Function CRC24_Bytes(abMessage() As Byte) As Long
'  - Returns the 24-bit CRC for an array of Bytes
' Public Function CRC24_String(sMessage As String) As Long
'  - Returns the 24-bit CRC for a String

' The function cv_BytesFromHex() used in the test is available in
' the module basConvert.txt


Public Function Test_CRC24()
' Tests for CRC-24 algorithm. Correct output is:-
'CRC24(3F214365876616AB15387D5D59)=BA0568
'CRC24(89003F0305...)=5982EA
'CRC24('hello world')=B03CB7
'CRC24('Hello world')=EDAB02
'CRC24('123456789')=21CF02

    Dim sTestHex As String
    Dim sTest As String
    Dim abOctets() As Byte
    Dim ulCRC As Long
    
    sTestHex = "3F214365876616AB15387D5D59"
    abOctets = cv_BytesFromHex(sTestHex)
    ulCRC = CRC24_Bytes(abOctets)
    Debug.Print "CRC24(" & sTestHex & ")=" & Hex(ulCRC)
    
    ' This test data is from a sample PGP message.
    sTestHex = "89003F0305013E978A669E02D8AE8DFD6EDE11027520009E2B90532BFD46E8FF1305758BE8DEC71C" & _
     "2C50FCCB009F6F6D5A91A80B89B7D570A6FE382BDEC5951426A6CD"
    abOctets = cv_BytesFromHex(sTestHex)
    ulCRC = CRC24_Bytes(abOctets)
    Debug.Print "CRC24(" & Left(sTestHex, 10) & "...)=" & Hex(ulCRC)
    
    sTest = "hello world"
    ulCRC = CRC24_String(sTest)
    Debug.Print "CRC24('" & sTest & "')=" & Hex(ulCRC)
    
    sTest = "Hello world"
    ulCRC = CRC24_String(sTest)
    Debug.Print "CRC24('" & sTest & "')=" & Hex(ulCRC)
    
    sTest = "123456789"
    ulCRC = CRC24_String(sTest)
    Debug.Print "CRC24('" & sTest & "')=" & Hex(ulCRC)
    
End Function

Public Function CRC24_Bytes(abMessage() As Byte) As Long
    Const CRC24_INIT As Long = &HB704CE
    Const CRC24_POLY As Long = &H1864CFB
    Dim i As Long
    Dim j As Integer
    Dim ulCRC As Long
    
    ulCRC = CRC24_INIT
    For i = LBound(abMessage) To UBound(abMessage)
        ulCRC = ulCRC Xor ulShiftLeftBy16(abMessage(i))
        For j = 0 To 7
            ulCRC = ulShiftLeftByOne(ulCRC)
            If (ulCRC And &H1000000) <> 0 Then
                ulCRC = ulCRC Xor CRC24_POLY
            End If
        Next
    Next
    
    CRC24_Bytes = ulCRC And &HFFFFFF

End Function

Public Function CRC24_String(sMessage As String) As Long

    Dim abMessage() As Byte
    
    ' Use proper VB function to get an array of bytes
    ' thus avoiding problems with Unicode/ANSI/DBCS character sets
    abMessage = StrConv(sMessage, vbFromUnicode)
    CRC24_String = CRC24_Bytes(abMessage)
    
End Function

Private Function ulShiftLeftBy16(ByVal wordX As Long) As Long
' Shift 32-bit long value to left by 16 bits
' i.e. VB equivalent of "wordX << 16" in C
' Avoiding problem with sign bit
' Copyright (C) 2000-03 DI Management Services Pty Ltd
    ulShiftLeftBy16 = (wordX And &H7FFF&) * &H10000
    If (wordX And &H8000&) <> 0 Then
        ulShiftLeftBy16 = ulShiftLeftBy16 Or &H80000000
    End If
End Function

Private Function ulShiftLeftByOne(ByVal wordX As Long) As Long
' Shift 32-bit long value to left by 1 bits
' i.e. VB equivalent of "wordX << 1" in C
' Avoiding problem with sign bit
' Copyright (C) 2000-03 DI Management Services Pty Ltd
    ulShiftLeftByOne = (wordX And &H7FFFFFFF) * &H2
    If (wordX And &H8000000) <> 0 Then
        ulShiftLeftByOne = ulShiftLeftByOne Or &H80000000
    End If
End Function