[AccessD] OT: Compare 2 directories

Jürgen Welz jwelz at hotmail.com
Sun Feb 12 01:22:23 CST 2006


I wrote a little ditty that synchronizes files between laptop and server.  
There is a function that returns the logged in user name not included here, 
but it opens a table that determines which tables to synch.  For each table, 
there is a folder with the name of the table.  For each record that has 
files, there is a subfolder beneath the table folder named with the PK.  For 
example, if a user synchs Company correspondence as indicated by that users 
settings in the Synch table, the routine opens the table of Companies, walks 
the AN PK field and checks to see if a folder exists for that PK, ie if AN 
PK = 12365, it looks in the base path (hard coded in the procedure as 
'C:\GOM\') to see if any files exist at

C:\GOM\tblCompany\12365\

and every other PK number below ...\tblCompany\

Each table also has a field(0) named like the name of the table, without the 
'tbl' prefix and an suffix of 'ID'.  tblCompany has a pk named 'CompanyID'.  
tblEmployee has a pk named 'EmployeeID'....

If a folder exists and any file exists in a folder, it checks to see if it 
exists in the server folder (base path 'S:\GOM\...') and if it doesn't, it 
copies it over.  If the path doesn't exist, it creates the path and then 
copies the file.  It also copies (and creates folders) in the opposite 
direction.  The synch routine does not check for file modified date, but it 
can be easily modified to notify users of which files have disparate sizes 
or modified dates hence requiring user intervention to decide which to keep, 
or work on a preset rule.

The routine begins with a call to 'SynchFiles'.  A users record might 
contain the following string in the 'Synch' field:  
Project;Estimate;Employee

and will synch the files beneath tblProject, tblEstimate and tblEmployee for 
each record that has files.  The routine was used to get every file for 
every active record from the server to the laptop.  If any file was created 
on a laptop while out of the office, that file was synched to the server 
when the routine ran.  If any file was created on the server while a laptop 
was out of the office, that made its way to the laptop.

One downside was that it was difficult to delete files.  For example, if a 
file had been synched to one laptop and the server copy was deleted, the 
file from the laptop would find its way back to the server and on subsequent 
laptops.  I wound up building a hierarchy of folders where files marked for 
deletion were kept and these were excluded from the synch.  These files had 
to be maintained for a month or more since, if a laptop was out of service 
for a day longer, the files that remained on the laptop would show up again. 
  We wound up deleteing all table related files from the laptops 
periodically and letting the synch run as files were marked inactive (no 
longer employed with us, project completed, estimate bid declined) just to 
cut down on the number of outdated files on the laptops as we were otherwise 
synching a couple gigs of files.  Once an initial synch ran (typically 30 
minutes), the subsequent maintenance synchs ran in a few minutes.

I used arrays to store file and path information where some might use 
collections.  Party on.

If you are just comparing a pair of directories, this might be a bit of 
overkill.....

Without futher ado:

Option Compare Database
Option Explicit

Private Declare Function CopyFileA Lib "kernel32" (ByVal ExistingFileName As 
String, _
    ByVal NewFileName As String, ByVal FailIfExists As Long) As Long

    Dim mLapFile() As String 'array of files matching criteria and path on 
Local drive
    Dim mSrvFile() As String 'array of files matching criteria and path on 
Server drive
    Dim mstrLapPath As String 'path of files to synch on Local drive
    Dim mstrSrvPath As String 'path of files to synch on Server drive
    Dim mstrFileCrit As String 'set to \*.*
    Dim gDb As DAO.Database
    Dim gstrSrvPath As String

Public Sub SynchFiles()
    On Error GoTo ErrorHandler

    Dim ar() As String
    Dim lngI As Long
    Dim r As DAO.Recordset
    Dim strSql As String
    Dim strActive As String

    DoCmd.Hourglass True
    Set gDb = CurrentDb
    mstrFileCrit = "\*.*"
    strSql = "Select Synch From usysUser Where LoginName = '" & fnUserName & 
"'"
    Set r = gDb.OpenRecordset(strSql)
    If Len(Nz(r!Synch, "")) Then
        If InStr(r!Synch, "Project") Then
            ReDim Preserve ar(lngI)
            ar(lngI) = "Project"
            lngI = lngI + 1
        End If
        If InStr(r!Synch, "Company") Then
            ReDim Preserve ar(lngI)
            ar(lngI) = "Company"
            lngI = lngI + 1
        End If
        If InStr(r!Synch, "Contact") Then
            ReDim Preserve ar(lngI)
            ar(lngI) = "Contact"
            lngI = lngI + 1
        End If
        If InStr(r!Synch, "Employee") Then
            ReDim Preserve ar(lngI)
            ar(lngI) = "Employee"
            lngI = lngI + 1
        End If
        If InStr(r!Synch, "Estimate") Then
            ReDim Preserve ar(lngI)
            ar(lngI) = "Estimate"
            lngI = lngI + 1
        End If
        For lngI = 0 To UBound(ar)
            Set r = gDb.OpenRecordset("Select " & ar(lngI) & "ID From tbl" & 
ar(lngI) & _
              " Where Deleted = False And IsActive = True")
            If Not r.EOF Then
                gstrLocalPath = "C:\GOM\"
                gstrSrvPath = "S:\GOM\"
                mstrLapPath = gstrLocalPath & "tbl" & ar(lngI) & "\"
                mstrSrvPath = gstrSERVERPATH & "tbl" & ar(lngI) & "\"
                GetFileList r, "tbl" & ar(lngI)
            End If
        Next
    End If

ExitRoutine:
    On Error Resume Next
    DoCmd.Hourglass False
    r.Close
    Set r = Nothing
    Exit Sub
ErrorHandler:
    With Err
        Select Case .Number
            Case Else
                MsgBox .Number & vbCrLf & .Description, vbInformation, 
"Error - SynchFiles"
        End Select
    End With
    'Resume 0
    Resume ExitRoutine
End Sub

Private Sub GetFileList(r As DAO.Recordset, strTable As String)
    On Error GoTo ErrorHandler

    Dim lngI As Long
    Dim lngJ As Long
    Dim lngC As Long
    Dim strFileName As String
    Dim strFilPthNm As String
    Dim strSubFolder As String

    ReDim mLapFile(0)
    ReDim mSrvFile(0)
    lngI = 1
    lngJ = 1
    r.MoveLast
    r.MoveFirst
    SysCmd acSysCmdInitMeter, "Getting Local and Server " & strTable & " 
File Lists", r.RecordCount
    Do Until r.EOF
        strSubFolder = r(0)
        If Len(Dir(mstrLapPath & strSubFolder, vbDirectory)) = 0 Then
            If Len(Dir(mstrSrvPath & strSubFolder, vbDirectory)) Then
                If Len(Dir(mstrSrvPath & strSubFolder & mstrFileCrit)) Then
                    MkDir (mstrLapPath & strSubFolder)
                End If
            End If
        Else
            strFilPthNm = mstrLapPath & strSubFolder & mstrFileCrit
            strFileName = Dir(strFilPthNm)
            Do While Len(strFileName)
                ReDim Preserve mLapFile(lngI)
                mLapFile(lngI) = strSubFolder & "\" & strFileName
                strFileName = Dir
                lngI = lngI + 1
            Loop
        End If
        If Len(Dir(mstrSrvPath & strSubFolder, vbDirectory)) = 0 Then
            If Len(Dir(mstrLapPath & strSubFolder, vbDirectory)) Then
                If Len(Dir(mstrLapPath & strSubFolder & mstrFileCrit)) Then
                    MkDir (mstrSrvPath & strSubFolder)
                End If
            End If
        Else
            strFilPthNm = mstrSrvPath & strSubFolder & mstrFileCrit
            strFileName = Dir(strFilPthNm)
            Do While Len(strFileName)
                ReDim Preserve mSrvFile(lngJ)
                mSrvFile(lngJ) = strSubFolder & "\" & strFileName
                strFileName = Dir
                lngJ = lngJ + 1
            Loop
        End If
        r.MoveNext
        lngC = lngC + 1
        SysCmd acSysCmdUpdateMeter, lngC
    Loop
    WalkFileList

ExitRoutine:
    On Error Resume Next
    Exit Sub
ErrorHandler:
    With Err
        Select Case .Number
            Case 75, 76
                If fnCreateBasePath(mstrLapPath & strSubFolder) And 
fnCreateBasePath(mstrSrvPath & strSubFolder) Then Resume Next
            Case Else
                MsgBox .Number & vbCrLf & .Description, vbInformation, 
"Error - GetFileList"
        End Select
    End With
    'Resume 0
    Resume ExitRoutine
End Sub

Private Sub WalkFileList()
    On Error GoTo ErrorHandler

    Dim blnFound As Boolean
    Dim lngI As Long
    Dim lngJ As Long

    blnFound = False
    If UBound(mLapFile) > 0 Then
        For lngI = 1 To UBound(mLapFile)
            If UBound(mSrvFile) < 1 Then
                blnFound = False
            Else
                For lngJ = 1 To UBound(mSrvFile)
                    If mLapFile(lngI) = mSrvFile(lngJ) Then
                        blnFound = True
                        Exit For
                    End If
                    blnFound = False
                Next
            End If
            If Not blnFound Then
                DoFileCopy mstrLapPath & mLapFile(lngI), mstrSrvPath & 
mLapFile(lngI), "Server", 1
            End If
        Next
    End If
    blnFound = False
    If UBound(mSrvFile) > 0 Then
        For lngJ = 1 To UBound(mSrvFile)
            If UBound(mLapFile) < 1 Then
                blnFound = False
            Else
                For lngI = 1 To UBound(mLapFile)
                    If mSrvFile(lngJ) = mLapFile(lngI) Then
                        blnFound = True
                        Exit For
                    End If
                    blnFound = False
                Next
            End If
            If Not blnFound Then
                DoFileCopy mstrSrvPath & mSrvFile(lngJ), mstrLapPath & 
mSrvFile(lngJ), "Laptop", 1
            End If
        Next
    End If

ExitRoutine:
    On Error Resume Next
    SysCmd acSysCmdRemoveMeter
    Exit Sub
ErrorHandler:
    With Err
        Select Case .Number
            Case Else
                MsgBox .Number & vbCrLf & .Description, vbInformation, 
"Error - WalkFileList"
        End Select
    End With
    'Resume 0
    Resume ExitRoutine
End Sub

Private Sub DoFileCopy(Source As String, Dest As String, Orig As String, 
ByVal intC As Integer)
    On Error GoTo ExitRoutine

    SysCmd acSysCmdInitMeter, "Copying " & Source & " to " & Orig, intC
    Copy Source, Dest

ExitRoutine:
    Exit Sub
    If Err = 70 Then
        MsgBox "File " & Source & " is open.  Can't Copy.  Press OK to 
continue file " & _
          "Synchronization."
    Else
        MsgBox Err.Description & Err.Number
        Err = 0
    End If
End Sub

Private Function fnCreateBasePath(strCreatePath As String) As Boolean
    On Error GoTo ErrorHandler

    Dim strPath As String
    Dim lngPos As Long

    strCreatePath = Trim$(strCreatePath)
    If Right$(strCreatePath, 1) <> "\" Then strCreatePath = strCreatePath & 
"\"
    lngPos = 7
    Do Until lngPos = 1
        lngPos = InStr(lngPos + 1, strCreatePath, "\")
        If lngPos Then
            strPath = Left$(strCreatePath, lngPos - 1)
            If Not Len(Dir(strPath, vbDirectory)) > 0 Then
                MkDir strPath
            End If
        End If
        lngPos = lngPos + 1
    Loop
    fnCreateBasePath = True

ExitRoutine:
    On Error Resume Next
    Exit Function
ErrorHandler:
    With Err
        Select Case .Number
            Case Else
                MsgBox .Number & vbCrLf & .Description & vbCrLf & vbCrLf & _
                " Error in creating Folder:  '" & strCreatePath & "'", _
                vbInformation, "Error - fnCreateBasePath"
        End Select
    End With
    'Resume 0
    Resume ExitRoutine
End Function

Private Function Copy(FileSrc As String, FileDst As String, Optional 
NoOverWrite As Boolean = True) _
  As Boolean
    On Error GoTo ErrorHandler

    Copy = CopyFileA(FileSrc, FileDst, NoOverWrite) = 1

ExitRoutine:
    On Error Resume Next
    Exit Function
ErrorHandler:
    With Err
        Select Case .Number
            Case Else
                MsgBox .Number & vbCrLf & .Description, vbInformation, 
"Error - Copy"
        End Select
    End With
    'Resume 0
    Resume ExitRoutine
End Function




Ciao
Jürgen Welz
Edmonton, Alberta
jwelz at hotmail.com





>From: "Joe Hecht" <jmhecht at earthlink.net>
>Any one have or know a tool where you can compare two
>directories and synchronize them.
>
>
>
>Thanks
>
>
>
>Joe Hecht
>
>jmhecht at earthlink.net





More information about the AccessD mailing list