Back up Back End Database

The BackupBackEnd function is called from the USysRegInfo table to back up the current database's back end (if there is one) to the path selected in the Extra Options dialog:

Public Function BackupBackEnd()

'Called from USysRegInfo

On Error GoTo ErrorHandler

Dim strBackEndDBNameAndPath As String Dim strBackEndDBName As String Dim strBackEndDBPath As String Dim strFilePath As String

Dim strFullDBName As String Dim strFileName As String Dim strFullPath() As String Dim strDBName As String Dim intUBound As Integer Dim strConnect As String

Set dbsCalling = CurrentDb

Set tdfsCalling = dbsCalling.TableDefs

Set fso = CreateObject("Scripting.FileSystemObject")

strCurrentDB = Application.CurrentProject.Name

Debug.Print "Current db: " & strCurrentDB

strDayPrefix = Format(Date, "mm-dd-yyyy")

intExtPosition = InStr(strCurrentDB, ".")

strExtension = Mid(strCurrentDB, intExtPosition)

intExtLength = Len(strExtension)

strExcludeTable = "zstblTablePrefixes"

Create backup path string depending on user choice. strPropName = "BackupChoice"

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

Check whether there are any linked tables, and exit if not.

strBackEndDBNameAndPath = ""

On Error Resume Next

Get back end database name from Connect property of a table.

For Each tdfCalling In tdfsCalling strTable = tdfCalling.Name Debug.Print "Table name: " & strTable strConnect = Nz(tdfCalling.Connect) Debug.Print "Connect property: " & strConnect If strConnect <> "" Then strBackEndDBNameAndPath = Mid(strConnect, _

InStr(strConnect, "=") + 1) Debug.Print "Back end db name and path: " _

& strBackEndDBNameAndPath GoTo ContinueBackup End If

Next tdfCalling

On Error GoTo ErrorHandler

No linked tables found.

strTitle = "No back end"

strPrompt = "There are no linked tables in this database; "

& "please use the Back up Database command instead" MsgBox strPrompt, vbExclamation + vbOKOnly, strTitle GoTo ErrorHandlerExit

ContinueBackup:

Extract back end name and path from Connect property string.

strFullPath = Split(strBackEndDBNameAndPath, -1, _

vbTextCompare) intUBound = UBound(strFullPath) strBackEndDBName = strFullPath(intUBound) strBackEndDBPath = Mid(strBackEndDBNameAndPath, 1, _

Len(strBackEndDBNameAndPath) - Len(strBackEndDBName)) Debug.Print "Database name: " & strBackEndDBName Debug.Print "Database path: " & strBackEndDBPath

On Error Resume Next

Check whether back end path is valid.

Set sfld = fso.GetFolder(strBackEndDBPath) If sfld Is Nothing Then strTitle = "Invalid path" strPrompt = strBackEndDBPath _

& " is an invalid path; please re-link tables and try again"

MsgBox strPrompt, vbOKOnly + vbExclamation, strTitle GoTo ErrorHandlerExit End If

If setup has not been done, copy zstblBackupInfo to 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

Select Case strBackupChoice Case "1" Same folder as back end database strBackupPath = strBackEndDBPath Case "2"

Backups folder under back end database folder strBackupPath = strBackEndDBPath & "BackupsX" Case "3"

Custom folder strBackupPath = strPath End Select

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

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

On Error GoTo ErrorHandler

Create proposed save name for backup.

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

Len(strBackEndDBName) - intExtLength) _ & " Copy " & BackEndSaveNo _ & " & strDayPrefix & strExtension strProposedSaveName = strBackupPath & strSaveName Debug.Print "Backup save name: " & strProposedSaveName strTitle = "Database backup" strPrompt = "Save back end 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

![BackEndSaveDate] = Format(Date, "d-mmm-yyyy") ![BackEndSaveNumber] = BackEndSaveNo .Update .Close End With fso.CopyFile Source:=strBackEndDBNameAndPath, _ destination:=strSaveName

ErrorHandlerExit: Exit Function

ErrorHandler:

& "; Description: " & Err.Description Resume ErrorHandlerExit

End Function

0 0

Post a comment