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