'*******************************************************************************
' MODULE:       modCRC16
' FILENAME:     modCRC16.bas
' AUTHOR:       Jared De Blander
' CREATED:      March 29, 2006
' COPYRIGHT:    Copyright (c) 2006 Jared De Blander. All Rights Reserved.
' WEBSITE:      http://www.jx90.com/
' E-MAIL:       jared@deblander.org
'
'LICENSE:
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
'
' DESCRIPTION:
' Returns a CRC16 of the input string. For example:
' txtOut.Text = modCRC16.CRC16(txtIn.Text)
'
'*******************************************************************************

Option Explicit

Private CRCHigh                                     As Byte
Private CRCLow                                      As Byte

Private CRC16High(15)                               As Byte
Private CRC16Low(15)                                As Byte


Public Function CRC16(theMessage As String) As String
    Dim bArrayIn()                                  As Byte
    Dim i                                           As Long
    Dim lEndAddress                                 As Long
    
    
    'init variables to default values
    startCRC16
    
    'convert the string to an array of bytes
    bArrayIn = StrConv(theMessage, vbFromUnicode)
    
    'add all the bytes to the CRC16
    lEndAddress = UBound(bArrayIn)
    For i = 0 To lEndAddress
        'add the high nible then the low nible
        CRC16AddNibble CRC16ShiftRight(bArrayIn(i), 4)      'the high nibble
        CRC16AddNibble (bArrayIn(i) And &HF)                'the low nibble
    Next
    
    CRC16 = Right("00" & Hex(CRCHigh), 2) & Right("00" & Hex(CRCLow), 2)
End Function

Private Sub startCRC16()
    'the initial CRC value must be reset each time
    CRCHigh = &HFF
    CRCLow = &HFF
    
    'the following only needs to be done once!
    If CRC16High(1) = 0 Then
        CRC16High(0) = &H0
        CRC16High(1) = &H10
        CRC16High(2) = &H20
        CRC16High(3) = &H30
        CRC16High(4) = &H40
        CRC16High(5) = &H50
        CRC16High(6) = &H60
        CRC16High(7) = &H70
        CRC16High(8) = &H81
        CRC16High(9) = &H91
        CRC16High(10) = &HA1
        CRC16High(11) = &HB1
        CRC16High(12) = &HC1
        CRC16High(13) = &HD1
        CRC16High(14) = &HE1
        CRC16High(15) = &HF1
    
        CRC16Low(0) = &H0
        CRC16Low(1) = &H21
        CRC16Low(2) = &H42
        CRC16Low(3) = &H63
        CRC16Low(4) = &H84
        CRC16Low(5) = &HA5
        CRC16Low(6) = &HC6
        CRC16Low(7) = &HE7
        CRC16Low(8) = &H8
        CRC16Low(9) = &H29
        CRC16Low(10) = &H4A
        CRC16Low(11) = &H6B
        CRC16Low(12) = &H8C
        CRC16Low(13) = &HAD
        CRC16Low(14) = &HCE
        CRC16Low(15) = &HEF
    End If
End Sub

Private Function CRC16ShiftLeft(ByVal theByte As Byte, Optional numOfShifts As Long) As Byte
    Dim countVar As Long
    CRC16ShiftLeft = theByte
    For countVar = 1 To numOfShifts
        CRC16ShiftLeft = (CRC16ShiftLeft And 127) * 2
    Next
End Function

Private Function CRC16ShiftRight(ByVal theByte As Byte, Optional numOfShifts As Long) As Byte
    Dim countVar As Long
    CRC16ShiftRight = theByte
    For countVar = 1 To numOfShifts
        CRC16ShiftRight = Int(CRC16ShiftRight / 2)
    Next
End Function

Private Sub CRC16AddNibble(theNibble As Byte)
    Dim lookupAddress                               As Byte
    
    '1. Extract the 4 top nibble of the CRC
    lookupAddress = CRC16ShiftRight(CRCHigh, 4)

    '2. XOR the the extracted bits with the nibble we are adding
    lookupAddress = lookupAddress Xor theNibble

    '3. Shift the CRC left 4 bits
    CRCHigh = CRC16ShiftLeft(CRCHigh, 4) Or CRC16ShiftRight(CRCLow, 4)
    CRCLow = CRC16ShiftLeft(CRCLow, 4)

    '4. XOR the new values with the value from the lookup tables.
    CRCHigh = CRCHigh Xor CRC16High(lookupAddress)
    CRCLow = CRCLow Xor CRC16Low(lookupAddress)
End Sub