Back up Database

The BackupFrontEnd function is called from the USysRegInfo table to back up the current database to the path selected in the Extra Options dialog:

Public Function BackupFrontEnd() 'Called from USysRegInfo

On Error GoTo ErrorHandler

Set dbsCalling = CurrentDb

Set tdfsCalling = dbsCalling.TableDefs

Set fso = CreateObject("Scripting.FileSystemObject")

strCurrentDB = Application.CurrentProject.Name

Debug.Print "Current db: " & strCurrentDB

intExtPosition = InStr(strCurrentDB, ".")

strExtension = Mid(strCurrentDB, intExtPosition)

intExtLength = Len(strExtension)

Create the backup path string depending on the user's choice, with a default of 2 ("Backups folder under the database folder") in case the user has not made a choice:

strPropName = "BackupChoice"

strBackupChoice = GetProperty(strPropName, "2") Debug.Print "Backup choice: " & strBackupChoice strPropName = "BackupPath" strPath = GetProperty(strPropName, "") Debug.Print "Custom backup path: " & strPath

Select Case strBackupChoice

Case "1"

Same folder as database strBackupPath = _

Application.CurrentProject.Path &

Case "2"

Backups folder under database folder strBackupPath = _

Application.CurrentProject.Path & "\Backups\"

Case "3"

Custom folder strBackupPath = strPath & End Select

Debug.Print "Backup path: " & strBackupPath Check whether the path is valid. On Error Resume Next

Set sfld = fso.GetFolder(strBackupPath) If sfld Is Nothing Then

If strBackupChoice = "3" Then strTitle = "Invalid path" strPrompt = strBackupPath _

& " is an invalid path; please select " _ & "another custom path" MsgBox strPrompt, vbOKOnly + vbExclamation, strTitle GoTo ErrorHandlerExit ElseIf strBackupChoice = "2" Then

Create folder.

Set sfld = fso.CreateFolder(strBackupPath) End If End If

If setup has not been done, copy zstblBackupInfo to the calling database:

strCallingDb = CurrentDb.Name strTable = "zstblBackupInfo"

Set tdfCalling = dbsCalling.TableDefs(strTable)

If tdfCalling Is Nothing Then

Debug.Print strTable & " not found; about to copy it" DoCmd.CopyObject destinationdatabase:=strCallingDb, _ newname:=strTable, _ sourceobjectType:=acTable, _ sourceobjectname:=strTable Debug.Print "Copied " & strTable End If

Create a proposed save name for the backup database file:

strDayPrefix = Format(Date, "mm-dd-yyyy") strSaveName = Left(strCurrentDB, _

Len(strCurrentDB) - intExtLength) & " Copy " & SaveNo _ & ", " & strDayPrefix & strExtension strProposedSaveName = strBackupPath & strSaveName Debug.Print "Backup save name: " & strProposedSaveName strTitle = "Database backup"

strPrompt = "Save database to " & strProposedSaveName _ & "?"

strSaveName = Nz(InputBox(prompt:=strPrompt, _

title:=strTitle, Default:=strProposedSaveName))

Deal with user canceling out of the InputBox.

If strSaveName = "" Then GoTo ErrorHandlerExit End If

Set rst = dbsCalling.OpenRecordset("zstblBackupInfo") With rst .AddNew

![SaveDate] = Format(Date, "d-mmm-yyyy") ![SaveNumber] = SaveNo .Update .Close End With fso.CopyFile Source:=CurrentDb.Name, _ destination:=strSaveName

ErrorHandlerExit: Exit Function

ErrorHandler:

MsgBox "Error No: " & err.Number & "; Description: " & _

err.Description Resume ErrorHandlerExit

End Function

0 0

Post a comment