Public Function CopyCurrentDatabase()
On Error GoTo Err_Handler
'creates a copy of the current db (frontend) to same folder with date/time suffix
'e.g. SDA_20170423014248.accdb
Dim fso As Object
Dim strOldPath As String, strNewPath As String, strTempPath As String, strFileSize As String
Dim newlength As Long
Set fso = CreateObject("Scripting.FileSystemObject")
strOldPath = CurrentDb.Name
strTempPath = Left(CurrentDb.Name, InStr(CurrentDb.Name, ".") - 1) & _
"_TEMP" & Mid(CurrentDb.Name, InStr(CurrentDb.Name, "."))
strNewPath = Left(CurrentDb.Name, InStr(CurrentDb.Name, ".") - 1) & _
"_" & Format(Now, "yyyymmddhhnnss") & Mid(CurrentDb.Name, InStr(CurrentDb.Name, "."))
If MsgBox("This routine is used to make a backup copy of the Access front end (FE) database. " & vbNewLine & vbNewline & _
"The backup will be saved to the same folder with current date/time suffix " & vbNewLine & _
vbTab & "e.g. " & strNewPath & " " & vbNewLine & vbNewLine & _
"This can be used for recovery in case of problems " & vbNewLine & vbNewLine & _
"Create a backup now?", _
vbExclamation + vbYesNo, "Copy the Access FE database?") = vbYes Then
'copy database to a temp file
fso.CopyFile strOldPath, strTempPath
Set fso = Nothing
strNewPath = Left(CurrentDb.Name, InStr(CurrentDb.Name, ".") - 1) & _
"_" & Format(Now, "yyyymmddhhnnss") & Mid(CurrentDb.Name, InStr(CurrentDb.Name, "."))
'compact the temp file
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
MsgBox "The Access FE database has been successfully backed up. " & vbNewLine & vbNewline & _
"The backup file is called " & vbNewLine & _
vbTab & strNewPath & " " & vbNewLine & vbNewLine & _
"The file size is " & strFileSize, vbInformation, "Access FE Backup completed"
End If
Exit_Handler:
Exit Function
Err_Handler:
Set fso = Nothing
If Err <> 0 Then
MsgBox "Error " & Err.Number & " in CopyCurrentDatabase procedure : " & _
" - " & Err.Description, vbCritical, "Error copying database"
End If
Resume Exit_Handler
End Function