VB Forum / General 2 / July 2008

'modCRC32.bas
Option Explicit

Private malTable(255) As Long

Public Sub Main()

    Dim sFile As String

    sFile = App.Path
    If Right$(sFile, 1) <> "\" Then sFile = sFile & "\"

    sFile = sFile & "modCRC32.bas"

    Debug.Print GetFileCRC(sFile)

End Sub

Private Function AddCrc32(ByVal sItem As String, ByVal lCRC32 As Long)
As Long

    Dim yCharValue As Byte
    Dim lCounter As Long
    Dim lIndex As Long
    Dim lAccValue As Long
    Dim lTableValue As Long

    For lCounter = 1 To Len(sItem)
        yCharValue = Asc(Mid$(sItem, lCounter, 1))
        lAccValue = lCRC32 And &HFFFFFF00
        lAccValue = lAccValue \ &H100
        lAccValue = lAccValue And &HFFFFFF
        lIndex = lCRC32 And &HFF
        lIndex = lIndex Xor yCharValue
        lTableValue = malTable(lIndex)
        lCRC32 = lAccValue Xor lTableValue
    Next lCounter

    AddCrc32 = lCRC32

End Function

Public Function ComputeCRC32(ByRef sString As String) As String

    Dim lCrc32Value As Long

    lCrc32Value = InitCrc32()
    lCrc32Value = AddCrc32(sString, lCrc32Value)

    ComputeCRC32 = Hex$(GetCrc32(lCrc32Value))

End Function

Public Function FileExists(ByVal sFilePath As String) As Boolean

    Dim nAttr As Integer

    FileExists = False

    If Len(sFilePath) = 0 Or InStr(sFilePath, "*") > 0 Or
InStr(sFilePath, "?") > 0 Then
        Exit Function
    End If

    On Error GoTo ErrorFileExist

    nAttr = VBA.GetAttr(sFilePath)

    FileExists = ((nAttr And vbDirectory) = 0)

ErrorFileExist:

End Function

Private Function GetCrc32(ByVal lCRC32 As Long) As Long

    GetCrc32 = lCRC32 Xor &HFFFFFFFF

End Function

Public Function GetFileCRC(ByRef sFile As String) As String

    Dim nF As Integer
    Dim lFileLen As Long
    Dim sCRC32 As String
    Dim sFileString As String

    sCRC32 = ""

    If FileExists(sFile) Then
        lFileLen = FileLen(sFile)

        sFileString = String$(lFileLen, 0)

        nF = FreeFile
        Open sFile For Binary As #nF
        Get #nF, 1, sFileString
        Close #nF

        sCRC32 = ComputeCRC32(sFileString)
    End If

    GetFileCRC = sCRC32

End Function

Private Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320,
Optional ByVal Precondition As Long = &HFFFFFFFF) As Long

    Dim iBytes As Integer
    Dim iBits As Integer
    Dim lCRC32 As Long
    Dim lTempCrc32 As Long

    For iBytes = 0 To 255

        lCRC32 = iBytes

        For iBits = 0 To 7
            lTempCrc32 = lCRC32 And &HFFFFFFFE
            lTempCrc32 = lTempCrc32 \ &H2
            lTempCrc32 = lTempCrc32 And &H7FFFFFFF

            If (lCRC32 And &H1) <> 0 Then
                lCRC32 = lTempCrc32 Xor Seed
            Else
                lCRC32 = lTempCrc32
            End If
        Next iBits

        malTable(iBytes) = lCRC32
    Next iBytes

    InitCrc32 = Precondition

End Function