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
'I will change here
strTableName = "POS_be.accdb" 'name of your linked table
'I will change here
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"
'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