Oscar Sun

                  Function 備分() '2007/10/29
Dim SourceFile, DestinationFile, fs, a, e
a = Array(CurrentProject.Name, "開發_千慮一得齋.mdb", "圖書管理_查詢版.mdb", "工具資料庫.mdb")
SourceFile = CurrentProject.FullName '"SRCFILE"    ' 指定來源檔名。
DestinationFile = Replace(CurrentProject.FullName, "D", "N", , 1) '"DESTFILE"    ' 指定目的檔名。
'Kill DestinationFile
'FileCopy SourceFile, DestinationFile    ' 將來源檔的內容複製到目的檔中。-此法檔案不可開啟!
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile SourceFile, DestinationFile
備分_壓縮檔案 DestinationFile, CurrentProject.Name
For e = 0 To UBound(a) - 1
    SourceFile = Replace(SourceFile, a(e), a(e + 1), , 1)
    DestinationFile = Replace(DestinationFile, a(e), a(e + 1), , 1)
    If fs.getfile(SourceFile).DateLastModified > fs.getfile(DestinationFile).DateLastModified Then
        fs.CopyFile SourceFile, DestinationFile
        備分_壓縮檔案 DestinationFile, a(e + 1)
    End If
Next
End Function
Sub 備分_壓縮檔案(DestinationFile, filename)
DBEngine.CompactDatabase DestinationFile, Replace(DestinationFile, filename, "temp.mdb")  '壓縮為暫存檔'當有引用,則不壓縮時會造成錯誤!
Kill DestinationFile '刪除選取檔案
FileCopy Replace(DestinationFile, filename, "temp.mdb"), DestinationFile             '還原
Kill Replace(DestinationFile, filename, "temp.mdb")   '刪除暫存檔
End Sub