Backing up and restore your tables (1 Viewer)

currentproject.path & "\" & currentproject.name
as suggested by: the_net_2.0

Private Sub Button_Backup_Click()
 
Dim str As String
Dim buf As String
Dim MD_Date As Variant
Dim fs As Object
Dim source As String
 
Const conPATH_FILE_ACCESS_ERROR = 75
On Error GoTo Backup_Button_Backup
 
'Where to backup to. Creates BACKUP folder is it does not exist
buf = CurrentProject.Path & "\Backups\"
MkDir buf
 
    Resume Backup_Button_Backup
 
Backup_Button_Backup:
 
'Create a folder in BACKUP with YYYY-mm-dd hhmm-ss as the name
 
MD_Date = Format(Date, "yyyy-mm-dd ") & Format(Time, "hh-mm-ss")
str = CurrentProject.Path & "\Backups\" & MD_Date
 
'Where is the data to backup 
source = CurrentProject.Path & "\Data\"
MkDir str
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile source & "*.accdb", str
Set fs = Nothing
 
'Successful
MsgBox "Data backup at " & vbCrLf & MD_Date & vbCrLf & "successfully!", _
        vbInformation, "Backup Successful"
 
Exit_Button_Backup:
 
  Exit Sub
 
'Use this part if you have not used hh-mm-ss
 
Err_Button_Backup:
  If err.Number = conPATH_FILE_ACCESS_ERROR Then
    MsgBox "The following Path, " & str & ", already exists or there was an Error " & _
           "accessing it!", vbExclamation, "Path/File Access Error"
  Else
    MsgBox err.Description, vbExclamation, "Error Creating " & str
 
End If
    Resume Exit_Button_Backup
End Sub

Private Sub Button_Restore_Click()
Dim frm As Object
 
'Close all forms
For Each frm In CurrentProject.AllForms
    If frm.IsLoaded Then
        DoCmd.Close acForm, frm.Name
    End If
Next frm
 
'Open a form F_Restore. I had to do this to give tables a chance to close. You could use a pause script.
    DoCmd.OpenForm "F_Restore", acNormal, "", "", , acNormal
End Sub

Private Sub Form_Timer()
 
If Me.Timer = 0 Then
Dim str As String
Dim buf As String
Dim MD_Date As Variant
Dim fs As Object
Dim source As String
Dim pubInputFolder As String
Dim txtfolder As String
Dim deletesource As String
Const conPATH_FILE_ACCESS_ERROR = 75
    On Error GoTo 0
 
With Application.FileDialog(4)
    .InitialFileName = CurrentProject.Path & "\Backups\"
    .AllowMultiSelect = False
    .Filters.Clear
    .Show
    pubInputFolder = .SelectedItems(1)
    txtfolder = pubInputFolder
End With
On Error GoTo Backup
'First we backup as before. This time R is added to the end of the folder name.
buf = CurrentProject.Path & "\Backups\"
MkDir buf
    Resume Backup
Backup:
MD_Date = Format(Date, "yyyy-mm-dd ") & Format(Time, "hh-mm-ss") & " R"
str = CurrentProject.Path & "\Backups\" & MD_Date
source = CurrentProject.Path & "\Data\"
MkDir str
 
'All backed up. Now we will ask you for the source folder for the data to be restored.
 
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile source & "*.accdb", str
Set fs = Nothing
 
'Delete the current data files
 
deletesource = CurrentProject.Path & "\Data\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile deletesource & "\*.accdb"
Set fs = Nothing
 
'Copy the files from the backup source to the DATA folder
Dim backupsource As String
Dim destination As String
backupsource = txtfolder
destination = CurrentProject.Path & "\Data\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile backupsource & "\*.*", destination & "\"
Set fs = Nothing
MsgBox "Data from " & vbCrLf & backupsource & vbCrLf & "successfully restored!", _
        vbInformation, "Restore Successful"
 
'Almost done
 
ExitBackup:
 
'Close the restore form
 
    DoCmd.Close acForm, "F_Restore"
 
'Open forms as you need them.
 
    DoCmd.OpenForm "_Admin", acNormal, "", "", , acHidden
    DoCmd.OpenForm "F__Menu", acNormal, "", "", , acNormal
 
  Exit Sub
 
 
ErrBackup:
  If err.Number = conPATH_FILE_ACCESS_ERROR Then
    MsgBox "The following Path, " & str & ", already exists or there was an Error " & _
           "accessing it!", vbExclamation, "Path/File Access Error"
  Else
    MsgBox err.Description, vbExclamation, "Error Creating " & str
 
    Resume ExitBackup
End If
Else
Me.Timer = Me.Timer - 1
End If
End Sub