Code:
On Error GoTo Err_Handler
'creates a copy of the backend database to the backups folder with date/time suffix
Dim fso As Object
Dim strOldPath As String, strNewPath As String, strTempPath As String, strFileSize As String
Dim newlength As Long
Dim STR_PASSWORD As String
'if your BE database is password protected, enter it below or state where it can be found
' STR_PASSWORD = "" 'enter password
' STR_PASSWORD = Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='Pwd'"), "") 'example for stored password
Set fso = CreateObject("Scripting.FileSystemObject")
strFilename = "DMT Live.accdb" 'replace with your BE file
strFileType = mID(strFilename, InStr(strFilename, ".")) 'e.g. .accdb
strOldPath = "T:\DMT" & strFilename 'replace GetLinkedDBFolder with your BE folder
'replace GetBackupsFolder with your backups folder
strNewPath = "T:\DMT\DB Backup" & Left(strFilename, InStr(strFilename, ".") - 1) & "_" & Format(Now, "yyyymmddhhnnss") & strFileType
'set path for temp file
strTempPath = "T:\DMT\DB Backup" & Left(strFilename, InStr(strFilename, ".") - 1) & "_TEMP" & strFileType
' Debug.Print strOldPath
' Debug.Print strTempPath
' Debug.Print strNewPath
If MsgBox("This procedure is used to make a backup copy of the back end database" & vbCrLf & _
"The backup will be saved to the Backups folder with date/time suffix" & vbCrLf & _
vbTab & "e.g. " & strNewPath & " " & vbCrLf & vbCrLf & _
"This can be used for recovery in case of problems " & vbCrLf & vbCrLf & _
"Create a backup now?", _
vbExclamation + vbYesNo, "Copy the Access BE database?") = vbNo Then
Exit Function
Else
'copy database to a temp file
fso.CopyFile strOldPath, strTempPath
Set fso = Nothing
'compact the temp file (with password)
DBEngine.CompactDatabase strTempPath, strNewPath, ";PWD=" & STR_PASSWORD & "", , ";PWD=" & STR_PASSWORD & ""
'OR compact the temp file code if no password
'DBEngine.CompactDatabase strTempPath, strNewPath
'delete the tempfile
Kill strTempPath
DoEvents
'get size of backup
newlength = FileLen(strNewPath) 'in bytes
'setup string to display file size
If FileLen(strNewPath) < 1024 Then 'less than 1KB
strFileSize = newlength & " bytes"
ElseIf FileLen(strNewPath) < 1024 ^ 2 Then 'less than 1MB
strFileSize = Round((newlength / 1024), 0) & " KB"
ElseIf newlength < 1024 ^ 3 Then 'less than 1GB
strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 2), 1) & " MB)"
Else 'more than 1GB
strFileSize = Round((newlength / 1024), 0) & " KB (" & Round((newlength / 1024 ^ 3), 2) & " GB)"
End If
DoEvents
End If
MsgBox "The Access backend database has been successfully backed up. " & _
"The backup file is called " & vbCrLf & vbTab & strNewPath & vbCrLf & vbCrLf & _
"The file size is " & strFileSize, vbInformation, "Access BE Backup completed"
Exit_Handler:
Exit Function
Err_Handler:
Set fso = Nothing
If Err <> 0 Then
MsgBox "Error " & Err.Number & " in BackupBEDatabase procedure : " & _
Err.Description, vbCritical, "Error copying database"
End If
Resume Exit_Handler
COMMAND BUTTON
'Dim sBackendPath As String
'Dim sFolder As String
'Dim sFilename As String
'Dim sExtension As String
'sBackendPath = "T:\DMT\DB Backend\DMT Live_be" & "accdb"
'sFolder = "T:\DMT\DB Backup"
'sFilename = "DMT Live_be" & "accdb"
' assume sBackendPath contains the full path to the backend
'Call ParseFullPath(sBackendPath, sFolder, sFilename, sExtension)
'sFolder = sFolder
'sFilename = sFilename & Format(Now(), "dd-mm-yy")
'FileCopy sBackendPath, sFolder & sFilename
BackupFEDatabase
BackupBEDatabase