Private Sub CmdCompactBE_Click()
'Courtesy of Brent Spaulding (datAdrenaline), MVP
'Modified by theDBguy on 5/27/2019
'Source: http://www.accessmvp.com/thedbguy
On Error GoTo errHandler
Dim oFSO As Object
Dim strDestination As String
Dim strSource As String
Dim strTableName As String
Dim strFileName As String
'Link of my BE file
strTableName = "D:\POS\Purchase Order- V6_be.accdb" 'name of your linked table
'Link of my backup Folder Path
strFileName = "D:\POS\Data File\BackUp" 'name of your backup file
'Get the source of your back end
strSource = Split(Split(CurrentDb.TableDefs(strTableName).Connect, "Database=")(1), ";")(0)
'Determine your destination
'strDestination = CurrentProject.Path & strFileName & " (" & Format(Now, "yyyymmddhhnnss") & ").accdb"
'Link my Backup File Destination
strDestination = "D:\POS\Data File\BackUp" & " (" & Format(Now, "ddmmyyyyhhnnss") & ").accdb"
'Flush the cache of the current database
DBEngine.Idle
'Create a file scripting object that will backup the db
Set oFSO = CreateObject("Scripting.FileSystemObject")
oFSO.CopyFile strSource, strDestination
Set oFSO = Nothing
'Compact the new file, ...
Name strDestination As strDestination & ".cpk"
DBEngine.CompactDatabase strDestination & ".cpk", strDestination
'Uncomment the following line and comment the previous line
'if your backend file is password protected or if you want the backup to have a password
'DBEngine.CompactDatabase strDestination & ".cpk", strDestination, , , ";pwd=YourPassword"
Kill strDestination & ".cpk"
'Notify users
MsgBox "Backup file '" & strDestination & "' has been created.", _
vbInformation, "Backup Completed!"
errExit:
Exit Sub
errHandler:
MsgBox Err.Number & ": " & Err.Description
Resume errExit
End Sub