Code: Select all
Option Explicit
'On Error Resume Next
MsgBox Calc_CRC("0012000D6F00002366BB") '338B
'-------------------------------------------------------
'- Calc CRC 16 CCITT (X-Modem) -------------------------
'-------------------------------------------------------
Function Calc_CRC(Data)
Dim crc
Dim nit
Dim bit
Dim tempcrc1
Dim tempcrc2
crc = 0
For nit = 1 To Len(Data)
tempcrc1 = 0
tempcrc2 = (((crc \ 256) Xor Asc(Mid(Data, nit, 1))) And 255) * 256
For bit = 0 To 7
If (tempcrc1 Xor tempcrc2) And 32768 Then
tempcrc1 = (tempcrc1 * 2) Xor &H1021
Else
tempcrc1 = tempcrc1 * 2
End If
tempcrc2 = tempcrc2 * 2
Next
crc = ((crc * 256) Xor tempcrc1) And 65535
Next
Calc_CRC = Hex(crc)
End Function