Public Function BackupBEDatabase()
On Error GoTo Err_Handler
'creates a copy of the backend database UKAddressFinderBE.accdb 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
STR_PASSWORD = ucp(Nz(DLookup("ItemValue", "tblProgramSettings", "ItemName='Pwd'"), ""))
Set fso = CreateObject("Scripting.FileSystemObject")
strFilename = "UKAddressFinderBE.accdb"
strFileType = Mid(strFilename, InStr(strFilename, ".")) 'e.g. .accdb
strOldPath = GetLinkedDBFolder & "\" & strFilename
strNewPath = GetBackupsFolder & "\BE\" & _
Left(strFilename, InStr(strFilename, ".") - 1) & "_" & Format(Now, "yyyymmddhhnnss") & strFileType
strTempPath = GetBackupsFolder & "\" & _
Left(strFilename, InStr(strFilename, ".") - 1) & "_TEMP" & strFileType
' Debug.Print strOldPath
' Debug.Print strTempPath
' Debug.Print strNewPath
If SilentFlag = True Then GoTo StartBackup:
If FormattedMsgBox("This procedure is used to make a backup copy of the Access back end database, UKAddressFinderBE.accdb. " & _
"@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
DoEvents
StartBackup:
If CurrentProject.AllForms("frmAdmin").IsLoaded Then
Forms!frmAdmin.lblInfo.visible = True
Forms!frmAdmin.lblInfo.Caption = "Creating a backup copy of the back end database . . ."
DoEvents
End If
'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 & ""
'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
FormattedMsgBox "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"
If CurrentProject.AllForms("frmAdmin").IsLoaded Then
Forms!frmAdmin.lblInfo.visible = False
Forms!frmAdmin.lblInfo.Caption = ""
End If
Exit_Handler:
Exit Function
Err_Handler:
Set fso = Nothing
If Err <> 0 Then
FormattedMsgBox "Error " & Err.Number & " in BackupBEDatabase procedure : " & _
"@" & Err.description & " @", vbCritical, "Error copying database"
End If
Resume Exit_Handler
End Function
