Attribute VB_Name = "basCRC16"
Option Explicit
Option Base 0

' basCRC16: Calculates CRC-16 checksum for a given message string
' Version 1. Published 6 May 2001.
' Updated 23 October 2006 - changed i from Integer to Long.
' Updated 17 June 2020 - changed license on this code to MIT.

' ******************************* LICENSE ***********************************
' * Copyright (C) 2001-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

Private aCRC16Table(255) As Integer

Public Function crc16(sMessage As String) As Integer
' Given table is already setup.
' Set iCRC = 0
' For each byte in message
'   calculate iCRC = (iCRC >> 8) ^ Table[(iCRC & 0xFF) ^ byte]
' Return iCRC
    
    Dim iCRC As Integer
    Dim i As Long
    Dim bytT As Byte
    Dim bytC As Byte
    Dim ia As Integer
    
    iCRC = 0
    For i = 1 To Len(sMessage)
        bytC = Asc(Mid(sMessage, i, 1))
        bytT = (iCRC And &HFF) Xor bytC
        ia = uiShiftRightBy8(iCRC)
        iCRC = ia Xor aCRC16Table(bytT)
    Next
    
    crc16 = iCRC

End Function

Public Function uiShiftRightBy8(x As Integer) As Integer
    ' Shift 16-bit integer value to right by 8 bits
    ' Avoiding problem with sign bit
    Dim iNew As Integer
    iNew = (x And &H7FFF) \ 256
    If (x And &H8000) <> 0 Then
        iNew = iNew Or &H80
    End If
    uiShiftRightBy8 = iNew
End Function

Public Function CRC16Setup()

    Dim vntA As Variant
    Dim i As Integer

    ' Use variant array kludge to set up table
    vntA = Array( _
        &H0, &HC0C1, &HC181, &H140, &HC301, &H3C0, &H280, &HC241, _
        &HC601, &H6C0, &H780, &HC741, &H500, &HC5C1, &HC481, &H440, _
        &HCC01, &HCC0, &HD80, &HCD41, &HF00, &HCFC1, &HCE81, &HE40, _
        &HA00, &HCAC1, &HCB81, &HB40, &HC901, &H9C0, &H880, &HC841, _
        &HD801, &H18C0, &H1980, &HD941, &H1B00, &HDBC1, &HDA81, &H1A40, _
        &H1E00, &HDEC1, &HDF81, &H1F40, &HDD01, &H1DC0, &H1C80, &HDC41, _
        &H1400, &HD4C1, &HD581, &H1540, &HD701, &H17C0, &H1680, &HD641, _
        &HD201, &H12C0, &H1380, &HD341, &H1100, &HD1C1, &HD081, &H1040)
        
    For i = 0 To 63
        aCRC16Table(i) = vntA(i - 0)
    Next
    
    vntA = Array( _
        &HF001, &H30C0, &H3180, &HF141, &H3300, &HF3C1, &HF281, &H3240, _
        &H3600, &HF6C1, &HF781, &H3740, &HF501, &H35C0, &H3480, &HF441, _
        &H3C00, &HFCC1, &HFD81, &H3D40, &HFF01, &H3FC0, &H3E80, &HFE41, _
        &HFA01, &H3AC0, &H3B80, &HFB41, &H3900, &HF9C1, &HF881, &H3840, _
        &H2800, &HE8C1, &HE981, &H2940, &HEB01, &H2BC0, &H2A80, &HEA41, _
        &HEE01, &H2EC0, &H2F80, &HEF41, &H2D00, &HEDC1, &HEC81, &H2C40, _
        &HE401, &H24C0, &H2580, &HE541, &H2700, &HE7C1, &HE681, &H2640, _
        &H2200, &HE2C1, &HE381, &H2340, &HE101, &H21C0, &H2080, &HE041)

    For i = 64 To 127
        aCRC16Table(i) = vntA(i - 64)
    Next
    
    vntA = Array( _
        &HA001, &H60C0, &H6180, &HA141, &H6300, &HA3C1, &HA281, &H6240, _
        &H6600, &HA6C1, &HA781, &H6740, &HA501, &H65C0, &H6480, &HA441, _
        &H6C00, &HACC1, &HAD81, &H6D40, &HAF01, &H6FC0, &H6E80, &HAE41, _
        &HAA01, &H6AC0, &H6B80, &HAB41, &H6900, &HA9C1, &HA881, &H6840, _
        &H7800, &HB8C1, &HB981, &H7940, &HBB01, &H7BC0, &H7A80, &HBA41, _
        &HBE01, &H7EC0, &H7F80, &HBF41, &H7D00, &HBDC1, &HBC81, &H7C40, _
        &HB401, &H74C0, &H7580, &HB541, &H7700, &HB7C1, &HB681, &H7640, _
        &H7200, &HB2C1, &HB381, &H7340, &HB101, &H71C0, &H7080, &HB041)

    For i = 128 To 191
        aCRC16Table(i) = vntA(i - 128)
    Next
    
    vntA = Array( _
        &H5000, &H90C1, &H9181, &H5140, &H9301, &H53C0, &H5280, &H9241, _
        &H9601, &H56C0, &H5780, &H9741, &H5500, &H95C1, &H9481, &H5440, _
        &H9C01, &H5CC0, &H5D80, &H9D41, &H5F00, &H9FC1, &H9E81, &H5E40, _
        &H5A00, &H9AC1, &H9B81, &H5B40, &H9901, &H59C0, &H5880, &H9841, _
        &H8801, &H48C0, &H4980, &H8941, &H4B00, &H8BC1, &H8A81, &H4A40, _
        &H4E00, &H8EC1, &H8F81, &H4F40, &H8D01, &H4DC0, &H4C80, &H8C41, _
        &H4400, &H84C1, &H8581, &H4540, &H8701, &H47C0, &H4680, &H8641, _
        &H8201, &H42C0, &H4380, &H8341, &H4100, &H81C1, &H8081, &H4040)

    For i = 192 To 255
        aCRC16Table(i) = vntA(i - 192)
    Next
    
End Function

Public Function TestCRC16()

' Test suite answers:
'CRC16('123456789') = BB3D
'CRC16('hello world')=39C1
'CRC16('Hello world')=F96A
'CRC16('a') = E8C1
'CRC16(' ') = D801

    Dim sMessage As String
    Dim iCRC As Integer
    
    Call CRC16Setup
    
    sMessage = "123456789"
    iCRC = crc16(sMessage)
    Debug.Print "crc16('" & sMessage & "')=" & Hex(iCRC)
    
    sMessage = "hello world"
    iCRC = crc16(sMessage)
    Debug.Print "crc16('" & sMessage & "')=" & Hex(iCRC)

    sMessage = "Hello world"
    iCRC = crc16(sMessage)
    Debug.Print "crc16('" & sMessage & "')=" & Hex(iCRC)

    sMessage = "a"
    iCRC = crc16(sMessage)
    Debug.Print "crc16('" & sMessage & "')=" & Hex(iCRC)

    sMessage = " "  ' (space char)
    iCRC = crc16(sMessage)
    Debug.Print "crc16('" & sMessage & "')=" & Hex(iCRC)


End Function