Comparing files using VBA/MS Access 97

Question

I'd like to compare two files having the same size but some differences in their binary content and to write the results in a table having the following structure:

How can I do that ?

Answer

Here are the functions which solve your task. Note: when files are equal the functions work fast - because StrComp(...) function is fast. But when files are unequal - these function work quite slowly but you get the result sooner or later...

Option Compare Database
Option Explicit

Global Const BYTE_SIZE = 8192 
Dim szSrcBuffer As String * 8192, szTgtBuffer As String * 8192

Dim mvarDummy

Public Function c_test()
    Dim strS1Path As String
    Dim strS2Path As String
    Dim strMsg As String
       
    strS1Path = "c:\tst\lib.mde"
    strS2Path = "c:\tst\lib0.mde"
    
    strMsg = "Comparing [" & strS1Path & "] and [" & strS2Path & "]..."
    dlibCompareFiles strS1Path, strS2Path, strMsg
End Function

Function dlibCompareFiles(szSrc As String, szTgt As String, strStatusBarText As String)
    On Error GoTo dlibCompareFiles_Err
    dlibCompareFiles = False

    Dim dbs As Database
    Dim rst As Recordset
    
    Set dbs = CodeDb()
    dbs.Execute ("delete * from [tblCmpResults]")
    Set rst = dbs.OpenRecordset("tblCmpResults", dbOpenDynaset, dbAppendOnly)
    
    Dim hfSrcFileNum As Integer, fSrcOpened As Integer
    Dim hfTgtFileNum As Integer, fTgtOpened As Integer
    Dim lRemain As Long
    Dim lFilePointer As Long, intCompareResult As Integer
    dlibCompareFiles = True

    hfSrcFileNum = FreeFile
    Open szSrc For Binary Access Read Shared As #hfSrcFileNum Len = BYTE_SIZE
    fSrcOpened = True
    hfTgtFileNum = FreeFile
    Open szTgt For Binary Access Read Shared As #hfTgtFileNum Len = BYTE_SIZE
    fTgtOpened = True
    lRemain = LOF(hfSrcFileNum)

    mvarDummy = SysCmd(SYSCMD_INITMETER, strStatusBarText, lRemain)
    lFilePointer = 1
    Do Until lRemain < BYTE_SIZE
        Get #hfSrcFileNum, lFilePointer, szSrcBuffer
        Get #hfTgtFileNum, lFilePointer, szTgtBuffer
        
        intCompareResult = StrComp(szSrcBuffer, szTgtBuffer, 0)
        Dim iii As Long
        Dim lngNeCounter As Long
        Dim lngNeChains As Long
        
        If intCompareResult <> 0 Then
        lngNeChains = lngNeChains + 1
        For iii = 1 To BYTE_SIZE
            If Mid(szSrcBuffer, iii, 1) <> Mid(szTgtBuffer, iii, 1) Then
                lngNeCounter = lngNeCounter + 1
                LogNeResult rst, lFilePointer + iii - 1, szSrc, szTgt, Mid(szSrcBuffer, iii, 1), Mid(szTgtBuffer, iii, 1)
            End If
        Next iii
        End If
        
        If intCompareResult <> 0 Then
           'dlibCompareFiles = False
           'Exit Function
        End If
        lFilePointer = lFilePointer + BYTE_SIZE
        mvarDummy = SysCmd(SYSCMD_UPDATEMETER, lFilePointer)
        lRemain = lRemain - BYTE_SIZE
        DoEvents
    Loop
    
    Get #hfSrcFileNum, lFilePointer, szSrcBuffer
    Get #hfTgtFileNum, lFilePointer, szTgtBuffer
    
    intCompareResult = StrComp(szSrcBuffer, szTgtBuffer, 0)
    If intCompareResult <> 0 Then
       dlibCompareFiles = False
       GoTo dlibCompareFiles_Done
       Exit Function
    End If

dlibCompareFiles_Done:
    mvarDummy = SysCmd(SYSCMD_CLEARSTATUS)
    If fSrcOpened = True Then Close #hfSrcFileNum
    If fTgtOpened = True Then Close #hfTgtFileNum
    DoEvents
    MsgBox "Cnt = " & lngNeCounter & ", Chains = " & lngNeChains
    Exit Function
dlibCompareFiles_Err:
    '''dlibShowError "dlibCompareFiles: " & Error
    GoTo dlibCompareFiles_Done
End Function

Function LogNeResult(ByRef mrst As Recordset, _
                      ByVal vlngOffset As Long, _
                      ByVal szSrc As String, _
                      ByVal szTgt As String, _
                      ByVal chrSrc As String, _
                      ByVal chrDst As String)
       On Error GoTo LogNeResult_Err
    mrst.AddNew
       mrst![Offset] = vlngOffset
       mrst![HexOffset] = Hex(vlngOffset)
       mrst![SrcPath] = szSrc
       mrst![DstPath] = szTgt
       mrst![SrcChr] = chrSrc
       mrst![srcByte] = CByte(Asc(chrSrc))
       mrst![srcByteHex] = smsHex(Asc(chrSrc))
       mrst![DstChr] = chrDst
       mrst![DstByte] = CByte(Asc(chrDst))
       mrst![DstByteHex] = smsHex(Asc(chrDst))
    mrst.Update
LogNeResult_exit:
    Exit Function
LogNeResult_Err:
    Resume LogNeResult_exit
End Function


Private Function smsHex(ByVal vvar As Variant, Optional ByVal intOutputLen As Integer = 2)
    Dim strRet As String
    strRet = Hex(vvar)
    If Len(strRet) = 0 Then
        smsHex = "??"
    ElseIf Len(strRet) < intOutputLen Then
        smsHex = String(intOutputLen - Len(strRet), "0") & strRet
    Else
        smsHex = strRet
    End If
End Function

Copyright © 1999-2008 by Shamil Salakhetdinov. Original version is published here All rights reserved.