Function RunSub()
BackUp
End Function
Sub BackUp()
Dim dTime As Date
Dim sFile As String
Dim sSrcDb As String
On Error Resume Next
dTime = InputBox("Create a backup at", , Time + TimeValue("00:00:05"))
If Err.Number <> 0 Then Exit Sub
Do Until Time = dTime
DoEvents
Loop
MsgBox "Time to create a backup"
Dim oDB As DAO.Database
sFile = CurrentProject.Path & "\" & Format(Date, "m-d-yy") & ".accdb"
If Dir(sFile) <> "" Then Kill sFile
'!!!!!!
' arnelgp
' CHANGE "data" with any linked tablename from your FrontEnd
'
sSrcDb = BackEndPath("data")
' open the backend
'
' note, no password
Set oDB = OpenDatabase(sSrcDb, False, False)
Call DBEngine.Workspaces(0).CreateDatabase(sFile, dbLangGeneral)
DoCmd.Hourglass True
Dim oTD As TableDef
For Each oTD In oDB.TableDefs
If Left(oTD.Name, 4) <> "MSys" Then
DoCmd.CopyObject sFile, oTD.Name, acTable, oTD.Name
'OR: DoCmd.TransferDatabase acExport, "Microsoft Access", sFile, acTable, oTD.Name, oTD.Name
End If
Next oTD
oDB.Close
Set oDB = Nothing
DoCmd.Hourglass False
MsgBox "Backup is stored in the same folder"
End Sub
Public Function BackEndPath(ByVal strLinkedTable) As String
Dim db As DAO.Database
Dim con As String
On Error GoTo err_handler
Set db = CurrentDb
con = db.TableDefs(strLinkedTable).Connect
BackEndPath = Mid$(con, InStr(con, "=") + 1)
exit_function:
Set db = Nothing
Exit Function
err_handler:
Debug.Print Err.Number
Resume exit_function
End Function