Using Access 2003 (2000 format)
I have a module that creates a Backup of Back End tables upon close of the database. TheAceMan1 provided me with a link to this solution. Following is the code...
This works fine for the tables that are linked to the Back End that was created as a result of splitting the database (in this case that Back End is called "Trinity Data_be.mdb"
However, there are other tables that are otherwise linked. tblNewGivingsArchive is linked to "Trinity Archive.mdb"
and
tblGiftInKindDonations, tblMiscellaneousDonations, tblMiscellaneousFunds, tblUCWDonations, tblUCWExtraAddress, tblUCWMembers are linked to "Trinity Miscellaneous.mdb"
These tables are not picked up in the Backup process. Is there a way to change the code to make that happen.
Tom
I have a module that creates a Backup of Back End tables upon close of the database. TheAceMan1 provided me with a link to this solution. Following is the code...
Code:
' Copyright 2005 Alexey Dybenko. All Rights Reserved.
' E-mail: alexdyb@PointLtd.com
Option Compare Database
Option Explicit
'Temporary database name during backup
Private Const cTempDatabase = "~DataFile~.MDT"
'Database password if required
Private Const cstrPassword = ""
Private Function GetAppOption(strOption As String) As Variant
'this function returns appliction options,
'you can replace it with your function or
'just read from hidden form with option values
Select Case strOption
Case "BackUpInterval"
GetAppOption = 1 'Every day
Case "BackupPath"
GetAppOption = "" 'if empty - then using application path
Case "LeaveCopies"
GetAppOption = 3 ' we leave 3 last backups
Case "CompactAfterBackUp"
GetAppOption = True 'we will compact BE
End Select
End Function
Public Function ToBackup() As Boolean
On Local Error GoTo ToBackup_Err
Dim dbData As Database
Dim datLastBackupDate As Date, intBackupInterval As Integer
If Len(cstrPassword) > 0 Then
Set dbData = DBEngine.OpenDatabase(WhereAttached(), False, False, ";pwd=" & cstrPassword)
Else
Set dbData = DBEngine.OpenDatabase(WhereAttached())
End If
datLastBackupDate = CDate(PrpGet(dbData, "LastBackUp"))
dbData.Close
intBackupInterval = GetAppOption("BackUpInterval")
If intBackupInterval = 0 Then GoTo ToBackup_End
If ((VBA.Date - datLastBackupDate) >= intBackupInterval) Then
ToBackup = True
End If
ToBackup_End:
Exit Function
ToBackup_Err:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Resume ToBackup_End
End Select
End Function
Public Function BackUpNow(Optional strFilename As String)
On Local Error GoTo BackUpNow_Err
Dim strMDTSourcePath As String, strBackupPath As String, intLeaveCopies As Integer
Dim strBackupFile As String, i As Integer, strTemp As String
Dim BackupArray() As String
Dim dbData As Database
DoCmd.Hourglass True
Call MsgBox("Creating a backup of the Back End tables." _
& vbCrLf & "It will be the 3rd entry in the Backup folder." _
, vbExclamation, "Backup process")
If Len(strFilename) = 0 Then
strMDTSourcePath = WhereAttached()
Else
strMDTSourcePath = strFilename
End If
strBackupPath = GetAppOption("BackupPath")
intLeaveCopies = GetAppOption("LeaveCopies")
If Len(strBackupPath) < 3 Then
strBackupPath = CurrentProject.Path & "\BackUp"
End If
If Len(Dir(strBackupPath & "\", vbDirectory)) = 0 Then
MkDir strBackupPath
End If
strBackupFile = strBackupPath & "\Backup_" & Format(Now, "yymmdd_hhmmss") & "_Of_" & Mid$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\") + 1)
If Len(Dir(strBackupFile)) > 0 Then
Kill strBackupFile
End If
FileCopy strMDTSourcePath, strBackupFile
strTemp = Dir(strBackupPath & "\Backup_" & "??????_??????" & "_Of_" & Mid$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\") + 1))
Do While Len(strTemp) > 0
ReDim Preserve BackupArray(1 To i + 1)
BackupArray(i + 1) = strTemp
strTemp = Dir
i = i + 1
Loop
BubbleSort BackupArray()
For i = 1 To UBound(BackupArray) - intLeaveCopies
Kill strBackupPath & "\" & BackupArray(i)
Next i
If Len(cstrPassword) > 0 Then
Set dbData = DBEngine.OpenDatabase(strMDTSourcePath, False, False, ";pwd=" & cstrPassword)
Else
Set dbData = DBEngine.OpenDatabase(strMDTSourcePath)
End If
PrpSet dbData, "LastBackUp", dbDate, Date
dbData.Close
If GetAppOption("CompactAfterBackUp") Then
Application.Echo True, "Compacting database..."
strTemp = Left$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\")) & cTempDatabase
If Len(Dir(strTemp)) > 0 Then Kill strTemp
If Len(cstrPassword) > 0 Then
CompactDatabase strMDTSourcePath, strTemp, ";pwd=" & cstrPassword, , ";pwd=" & cstrPassword
Else
CompactDatabase strMDTSourcePath, strTemp
End If
Kill strMDTSourcePath
Name strTemp As strMDTSourcePath
End If
BackUpNow_End:
DoCmd.Hourglass False
Application.Echo True
Exit Function
BackUpNow_Err:
Select Case Err.Number
Case 70, 3356
MsgBox "Cannot backup just now - the database is already open:" & vbCrLf & "" _
& strMDTSourcePath _
& vbCrLf & "Backing up is to be perfomed on the first user logging in." _
& " Since you watch this message," _
& vbCrLf & "- either some workstation has not been configured to backup automatically," _
& vbCrLf & "- or some workstation has an invalid system date/time setting.", vbInformation
Resume BackUpNow_End
Case 68, 71, 76
MsgBox "Backup failed!" _
& "@Backup folder is not available or cannot be created or device is not ready." _
& "@Open Program Options Dialog and choose an existing Backup Folder.", vbInformation '
Resume BackUpNow_End
Case Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Resume BackUpNow_End
End Select
End Function
Sub BubbleSort(pstrItem() As String)
Dim intDone As Integer, intRow As Integer, intLastItem As Integer
intLastItem = UBound(pstrItem)
Do
intDone = True
For intRow = 1 To intLastItem - 1
If pstrItem(intRow) > pstrItem(intRow + 1) Then
SwapStr pstrItem(), intRow, intRow + 1
intDone = False
End If
Next
Loop Until intDone
End Sub
Sub SwapStr(pstrItem() As String, ByVal pintRow1 As Integer, ByVal pintRow2 As Integer)
' Swaps two elements of pstrItem()
'
' Called from all sort routines except strInsertSort
'
Dim strTemp As String
'
strTemp = pstrItem(pintRow1)
pstrItem(pintRow1) = pstrItem(pintRow2)
pstrItem(pintRow2) = strTemp
End Sub
Public Function WhereAttached() As String
Dim MyTable As TableDef
Dim MyDB As Database
Dim i As Integer
Dim intPos1 As Integer, intPos2 As Integer
On Error GoTo Err_WhereAttached
WhereAttached = ""
Set MyDB = CurrentDb
For i = 0 To MyDB.TableDefs.Count - 1
Set MyTable = MyDB.TableDefs(i)
If MyTable.Connect <> "" Then
intPos1 = InStr(1, MyTable.Connect, "DATABASE=")
If intPos1 > 0 Then
intPos2 = InStr(intPos1, MyTable.Connect, ";")
If intPos2 > 0 Then
WhereAttached = VBA.Mid$(MyTable.Connect, intPos1 + 9, intPos2 - intPos1 - 9)
Else
WhereAttached = VBA.Mid$(MyTable.Connect, intPos1 + 9)
End If
End If
Exit For
End If
Next i
Exit_WhereAttached:
Exit Function
Err_WhereAttached:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Resume Exit_WhereAttached
End Function
Private Function PrpGet(dbs As Database, strPrpName As String) As Variant
On Local Error Resume Next
PrpGet = dbs.Containers!Databases.Documents("UserDefined").Properties(strPrpName).Value
End Function
Public Function PrpSet(dbs As Database, strPropName As String, intPropType _
As Integer, varGen As Variant) As Boolean
Dim doc As Document, prp As Property, cnt As Container
Const conPropertyNotFound = 3270 ' Property not found error.
Set cnt = dbs.Containers!Databases ' Define Container object.
On Local Error GoTo PrpSet_Err
Set doc = cnt.Documents!UserDefined
doc.Properties.Refresh
' Set custom property name. If error occurs here it means
' property doesn't exist and needs to be created and appended
' to Properties collection of Document object.
Set prp = doc.Properties(strPropName)
prp = varGen
PrpSet = True
PrpSet_Bye:
Exit Function
PrpSet_Err:
If Err = conPropertyNotFound Then
Set prp = doc.CreateProperty(strPropName, intPropType, varGen)
doc.Properties.Append prp ' Append to collection.
Resume Next
ElseIf Err.Number = 3265 Then
Resume PrpSet_Bye
Else ' Unknown error.
PrpSet = False
Resume PrpSet_Bye
End If
End FunctionThis works fine for the tables that are linked to the Back End that was created as a result of splitting the database (in this case that Back End is called "Trinity Data_be.mdb"
However, there are other tables that are otherwise linked. tblNewGivingsArchive is linked to "Trinity Archive.mdb"
and
tblGiftInKindDonations, tblMiscellaneousDonations, tblMiscellaneousFunds, tblUCWDonations, tblUCWExtraAddress, tblUCWMembers are linked to "Trinity Miscellaneous.mdb"
These tables are not picked up in the Backup process. Is there a way to change the code to make that happen.
Tom