备份/还原Access数据库

这是用于备份和还原访问数据库的示例代码

Dim DBTempSource As Database
Dim DBTempDestination As Database 
Dim RecTempSource As Recordset
Dim RecTempDestination As Recordset 
Sub MBackup() 
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo Errors
If OptBackup Then
    TxtRemarks = "Backup Started at " & Time
    TxtRemarks = TxtRemarks & vbCrLf & "Closing Connection ...!"
    GCnnGeneral.Close
    TxtRemarks = TxtRemarks & vbCrLf & "Checking Destination ...!"
    If GFileExists(TxtDestination) Then
        Kill TxtDestination
    End If 
    TxtRemarks = TxtRemarks & vbCrLf & "Compacting Source ..."
    DBEngine.CompactDatabase TxtSource, TxtDestination, , , ";pwd=Debasis"
    TxtRemarks = TxtRemarks & vbCrLf & "Destination Created ...!"
    TxtRemarks = TxtRemarks & vbCrLf & "Connecting Database ...!"
    With GCnnGeneral
       .Provider = "Microsoft.Jet.OLEDB.4.0"
       .Properties("Jet OLEDB:Database Password") = "Debasis"
       .Mode = adModeReadWrite
       .Open App.Path & "\" & Trim(GFileName) & ".MDB"
    End With
    'GFileName = Trim(LstDatabase.Text)
    TxtRemarks = TxtRemarks & vbCrLf & "Backup Created at " & Time
    MsgBox "Backup Created."
    TxtSource = GEmptyStr
    TxtDestination = GEmptyStr
ElseIf OptRestore Then
    'GCnnAccts.Close
    TxtRemarks = "Restoring Data Started at " & Time
    GCnnGeneral.Close
    TxtRemarks = TxtRemarks & vbCrLf & "Connection Closed ...!"
    Kill TxtDestination
    TxtRemarks = TxtRemarks & vbCrLf & "Destination Checked ...!"
    Call FSO.CopyFile(TxtSource, TxtDestination, True)
    TxtRemarks = TxtRemarks & vbCrLf & "Data Restored ...!"
    With GCnnGeneral
       .Provider = "Microsoft.Jet.OLEDB.4.0"
       .Properties("Jet OLEDB:Database Password") = "Debasis"
       .Mode = adModeReadWrite
       .Open App.Path & "\" & Trim(GFileName) & ".MDB"
    End With
    TxtRemarks = TxtRemarks & vbCrLf & "Connection Complete ...!"
    TxtRemarks = TxtRemarks & vbCrLf & "Data Restored at " & Time
    MsgBox "Data Restored."
End If 
Exit Sub
Errors:
    MsgBox "[ErrNo.: " & Err.Number & "] " & Err.Description
End Sub 
Private Sub CmdBackup_Click()
If Trim(TxtSource) = GEmptyStr Then
    MsgBox "Source Filename Empty."
    Exit Sub
End If 
If Trim(TxtDestination) = GEmptyStr Then
    MsgBox "Destination Filename Empty."
    Exit Sub
End If 
If OptBackup Then
    If Not GFileExists(TxtSource) Then
        MsgBox "Source File Does Not Exist! Please Contact Program Vendor."
        Exit Sub
    End If
    If GFileExists(TxtDestination) Then
        If MsgBox("Destination File Already Exists! Do you Want to Replace the File?", vbYesNo + vbQuestion) = vbNo Then
            Exit Sub
        End If
    End If
ElseIf OptRestore Then
    If Not GFileExists(TxtSource) Then
        MsgBox "Source File Does Not Exist! Check Filename and Path."
        Exit Sub
    End If
End If
Call MBackup
End Sub 
Private Sub CmdDestinationSearch_Click()
If OptBackup Then
    CDOpen.DefaultExt = "Bak"
    CDOpen.FileName = "Temp.Bak"
    CDOpen.ShowSave
    TxtDestination = CDOpen.FileName
Else
    TxtDestination = Replace(App.Path & "\" & Trim(GFileName) & ".MDB", "\\", "\")  'GFileName
End If
End Sub 
Private Sub CmdExit_Click()
Unload Me
End Sub 
Private Sub CmdSourceSearch_Click()
If OptBackup Then
    TxtSource = Replace(App.Path & "\" & Trim(GFileName) & ".MDB", "\\", "\")    'GFileName
Else
    CDOpen.DefaultExt = "Bak"
    CDOpen.FileName = "Temp.Bak"
    CDOpen.ShowOpen
    TxtSource = CDOpen.FileName
End If
End Sub 
Private Sub Form_Resize()
Me.Left = (FrmBackground.Width - Me.Width) / 2
Me.Top = (FrmBackground.Height - Me.Height) / 2
End Sub 
Private Sub OptAll_Click()
FraPart.Visible = False
End Sub 
Private Sub OptBackup_Click()
CmdBackup.Caption = OptBackup.Caption & " &File"
TxtRemarks = GEmptyStr
End Sub 
Private Sub OptPart_Click()
FraPart.Visible = True
DtpFrom = Format(DateAdd("d", 7, GTransactDate), "dd/MMM/yyyy")
DtpTo = Format(GTransactDate, "dd/MMM/yyyy")
End Sub 
Private Sub OptRestore_Click()
CmdBackup.Caption = OptRestore.Caption & " &File"
TxtRemarks = GEmptyStr
End Sub 

注意：-用户可以通过添加/更改/删除控件名称和代码的其他部分来自定义上述代码。

From: https://bytes.com/topic/visual-basic/insights/783723-backup-restore-access-database