Code follows. Paste into a standard module, and fix up the line endings.
It's not thoroughly tested, and does not include the code to restore the
backup if you need it later, due to the concurrency issues.
--
Allen Browne - Microsoft MVP. Perth, Western Australia.
Reply to group, rather than allenbrowne at mvps dot org.
GOL said:
Thanks, where can I find info. on the routine that loops and and copies my
tables. I will use this at the present time and continue to copy database
at
end of day until I can come up with a permanent solution.
-------------code starts------------------------
'Author: Allen J Browne, November 2004.
[email protected]
'Purpose: Programmatically backup the tables in an Access database while
it is in use.
'Creates a new database file in the specified location,
' using the name of this with date and time appended.
'The target database contains all *tables* in this database, except:
' - system tables (dbSystemObject attribute),
' - temporary tables (name starts with ~),
' - tables that have a custom property set to No. Property name:
"NoBackup".
'Use MarkForNoBackup() to create/set the custom property.
'The data from linked tables is backed up.
'The tables in the backup database are *data* only,
' i.e. no relationships, no indexes, no validation rules, and properties
are not set.
'A table is not backed up if someone has it open exclusively (e.g. in design
view).
'A table may be only partially backed up if a write-conflict occurs.
'These conditions are recorded in a table named "_BackupErrors" in the
target file.
'If one table fails, it continues trying the following ones.
'TransferDatabase and CopyObject were not used, since they don't backup
linked tables.
'Objects other than tables are not backed up.
'BackupData() is the main function. TestBackup() illustrates how to use it.
Option Compare Database
Option Explicit
'Name of the table to create in the backup file, to record any errors when
backing up.
Const strcErrorTable = "_BackupErrors"
'Name of the custom property to mark tables for no backup.
Const strcPropNoBackup = "NoBackup"
Public Function TestBackup()
'Purpose: Exmaple of how to call BackupData()
Dim bFileCreated As Boolean
Dim strError As String
Dim strTitle As String
Dim lngIcon As VbMsgBoxStyle
bFileCreated = BackupData("C:\Backup", strError)
If Len(strError) > 0 Then
If bFileCreated Then
lngIcon = vbExclamation
strTitle = "Backup created, with errors"
Else
lngIcon = vbCritical
strTitle = "No backup created"
End If
MsgBox strError, lngIcon, strTitle
End If
TestBackup = "Done"
End Function
Public Function BackupData(varPath As Variant, Optional strErrMsg As String)
As Boolean
'On Error GoTo Err_Handler
'Arguments: varPath = the folder where the backup should be created.
' strErrMsg = string to append error messages to.
'Return: True if a backup was created.
Dim ws As DAO.Workspace 'Default workspace.
Dim dbLocal As DAO.Database 'This database.
Dim dbBackup As DAO.Database 'The backup database we are creating.
Dim tdf As DAO.TableDef 'Each table in turn.
Dim rsError As DAO.Recordset 'Error table, created in backup
database.
Dim strSql As String 'SQL statement.
Dim strFile As String 'Name of file to create.
Dim strPath As String 'Argument as a string.
Dim lngLen As Long 'Length of string.
Dim bCancel As Boolean 'Flag to cancel the backup.
'*********************************************
'Check the backup location is available.
'*********************************************
strPath = Trim$(Nz(varPath, vbNullString))
'Was a path supplied?
If Len(strPath) = 0 Then
bCancel = True
strErrMsg = strErrMsg & "No path supplied for backup." & vbCrLf
Else
'Add trailing slash if not there.
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
'Can we find this path?
If Len(Dir$(strPath, vbDirectory)) = 0 Then
bCancel = True
strErrMsg = strErrMsg & "Path not found: " & strPath & vbCrLf
End If
End If
If Not bCancel Then
'*********************************************
'Create the database file to export to.
'*********************************************
Set ws = DBEngine(0)
Set dbLocal = ws(0)
strFile = CurrentProject.Name
'Without the extension.
lngLen = InStrRev(strFile, ".") - 1
If lngLen > 0 Then
strFile = Left$(strFile, lngLen)
End If
'Add the path, file name, date and time, and extension.
strFile = strPath & strFile & Format(Now(), "\_yyyymmdd\-hhnnss") &
".mdb"
'Remove this file if it already exists.
If Len(Dir$(strFile)) > 0 Then
Kill strFile
End If
'Create the backup, turning off the Name AutoCorrect properties.
Set dbBackup = ws.CreateDatabase(strFile, dbLangGeneral)
With dbBackup
.Properties.Append .CreateProperty("Perform Name AutoCorrect",
dbLong, 0)
.Properties.Append .CreateProperty("Track Name AutoCorrect
Info", dbLong, 0)
End With
'*********************************************
'Loop through tables, skipping temp tables, system tables, and those
marked for no backup.
'*********************************************
For Each tdf In dbLocal.TableDefs
If Not ((tdf.Name Like "~*") Or (IsNoBackup(tdf)) Or
((tdf.Attributes And dbSystemObject) <> 0)) Then
Call BackupTable(dbLocal, dbBackup, tdf.Name, rsError,
strErrMsg)
End If
Next
'Report if errors were logged.
If Not rsError Is Nothing Then
strErrMsg = strErrMsg & rsError.RecordCount & " error(s) in " &
strFile & vbCrLf & _
"For details, see the table " & strcErrorTable & vbCrLf
End If
'Return value
BackupData = True
End If
Exit_Handler:
'Clean up.
On Error Resume Next
If Not rsError Is Nothing Then
rsError.Close
Set rsError = Nothing
End If
Set tdf = Nothing
Set dbBackup = Nothing
Set dbLocal = Nothing
Set ws = Nothing
Exit Function
Err_Handler:
strErrMsg = strErrMsg & "BackupData() did not complete. Error " &
Err.Number & ":" & vbCrLf & Err.Description & vbCrLf
Resume Exit_Handler
End Function
Public Function MarkForNoBackup(strTableName As String, bNoBackup As
Boolean)
On Error GoTo Err_Handler
'Purpose: Create or change the property for a table not to be backed
up.
'Arguments: strTableName: the name of the table to set.
' bNoBackup: True to set it for no backup.
' False to reset for backup.
'Example: Set Table1 NOT to be backed up:
' Call MarkForNoBackup("Table1", True)
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strErr As String
Set db = CurrentDb()
Set tdf = db.TableDefs(strTableName)
Call SetPropertyDAO(tdf, strcPropNoBackup, dbBoolean, bNoBackup, strErr)
Exit_Handler:
On Error Resume Next
If Len(strErr) > 0 Then
MsgBox strErr, vbExclamation, "MarkForNoBackup(""" & strTableName &
""", " & bNoBackup & ")"
End If
Set tdf = Nothing
Set db = Nothing
Exit Function
Err_Handler:
strErr = strErr & "Error " & Err.Number & " - " & Err.Description
Resume Exit_Handler
End Function
Private Function IsNoBackup(tdf As DAO.TableDef) As Boolean
'Purpose: Return True if the table has the custom property for No
Backup, and it is set to True.
On Error Resume Next
IsNoBackup = tdf.Properties(strcPropNoBackup)
End Function
Private Function BackupTable(dbLocal As DAO.Database, dbBackup As
DAO.Database, _
strTable As String, rsError As DAO.Recordset, strErrMsg As String) As
Boolean
On Error GoTo Err_Handler
'Purpose: Create a copy of this table into the target database.
'Arguments: dbLocal = this database.
' dbBackup = the backup database.
' strTable = name of the table to be backed up.
' rsError = the error table in the backup database to append
error messages to.
' strErrMsg = string to append error messages to if the error
messages can't be written.
Dim strSql As String
DoCmd.Echo True, "Backing up table: " & strTable 'Display the name of
the table.
strSql = "SELECT * INTO [" & strTable & "] IN """ & dbBackup.Name & """
FROM [" & strTable & "];"
dbLocal.Execute strSql, dbFailOnError
BackupTable = True
Exit_Handler:
Exit Function
Err_Handler:
Call WriteError(dbBackup, rsError, strTable, acTable, Err.Number,
Err.Description, strErrMsg)
Resume Exit_Handler
End Function
Private Function WriteError(dbBackup As DAO.Database, rsError As
DAO.Recordset, _
strObjectName As String, lngObjectType As AcObjectType, _
ByVal lngErrNum As Long, ByVal strErrDescrip As String, strErrMsg As
String) As Boolean
'On Error GoTo Err_Handler
'Purpose: Write an entry to the error table in the target database.
'Arguments: dbBackup = the database where the error table resides.
' rsError = the error table in that database. Created if
not already open.
' strObjectName = name of the table.
' lngObjectType = acTable, acQuery, ...
' strErrMsg = string to append message to if this write
also fails.
'Return: True if the error message was written to the table.
Dim strSql As String 'DDL string.
'Create the error table if this is the first error.
If rsError Is Nothing Then
strSql = "CREATE TABLE " & strcErrorTable & _
"(BackupErrorID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _
"ObjectName TEXT(255), ObjectType LONG, ErrNum LONG, ErrDescrip
MEMO);"
dbBackup.Execute strSql, dbFailOnError
With dbBackup.TableDefs(strcErrorTable)
.Properties.Append .CreateProperty(strcPropNoBackup, dbBoolean,
True)
End With
Set rsError = dbBackup.OpenRecordset(strcErrorTable, dbOpenDynaset,
dbAppendOnly)
End If
'Write the error to to table.
With rsError
.AddNew
!ObjectName = strObjectName
!ObjectType = lngObjectType
!ErrNum = lngErrNum
If Len(strErrDescrip) > 0 Then
!ErrDescrip = strErrDescrip
End If
.Update
End With
WriteError = True
Exit_Handler:
Exit Function
Err_Handler:
strErrMsg = strErrMsg & "Error " & Err.Number & " - " & Err.Description
& vbCrLf
Resume Exit_Handler
End Function
-------------code ends------------------------
