Function CRC_Calc(CRC_Message As String) As String
'Calculates a 16 bit checksum of a String of any length.
Dim Polynomial16 As Long
Dim Y As Integer
Dim Char_Text_DEC As Long
Dim X As Integer
Y = 1
X = 0
CRC_value = 0
Polynomial16 = 33800 'Polynomial &H8408
For Y = 1 To Len(CRC_Message)
CRC_Text_Single = Mid$(CRC_Message, Y, 1)
Char_Text_DEC = Asc(CRC_Text_Single)
For X = 1 To 8
LSB_CRC = CRC_value And &H1
LSB_Char = Char_Text_DEC And &H1
If LSB_CRC = 1 And LSB_Char = 1 Or LSB_CRC = 0 And LSB_Char = 0 Then
CRC_value = Fix(CRC_value / 2)
Char_Text_DEC = Fix(Char_Text_DEC / 2)
ElseIf LSB_CRC = 0 And LSB_Char = 1 Or LSB_CRC = 1 And LSB_Char = 0 Then
CRC_value = Fix(CRC_value / 2)
Char_Text_DEC = Fix(Char_Text_DEC / 2)
CRC_value = Polynomial16 Xor CRC_value
Else
End If
Next X
Next Y
If Len(Hex(CRC_value)) = 4 Then
CRC_LO = Mid$(Hex(CRC_value), 3, 2)
CRC_HI = Mid$(Hex(CRC_value), 1, 2)
ElseIf Len(Hex(CRC_value)) = 3 Then
CRC_STRING = "0" & Hex(CRC_value)
CRC_LO = Mid$(CRC_STRING, 3, 2)
CRC_HI = Mid$(CRC_STRING, 1, 2)
ElseIf Len(Hex(CRC_value)) = 2 Then
CRC_STRING = "00" & Hex(CRC_value)
CRC_LO = Mid$(CRC_STRING, 3, 2)
CRC_HI = Mid$(CRC_STRING, 1, 2)
ElseIf Len(Hex(CRC_value)) = 1 Then
CRC_STRING = "000" & Hex(CRC_value)
CRC_LO = Mid$(CRC_STRING, 3, 2)
CRC_HI = Mid$(CRC_STRING, 1, 2)
ElseIf Len(Hex(CRC_value)) = 0 Then
CRC_LO = "00"
CRC_HI = "00"
End If
CRC_Calc = Chr("&h" & CRC_LO) & Chr("&h" & CRC_HI)
'CRC_Calc = Chr(CRC_value Mod 256) & Chr(CRC_value \ 256) 'ALTERNATIVE METHOD
End Function