P
PC User
I have this code from a db of a previous version of access to archive
a database. I'm using A2K and it works when I set the references to
DAO. It creates archival copies of all objects in the current database
into a new database. This procedure uses the DAO CreateDatabase method
to create a new empty database. It then uses the TransferDatabase
action to copy all objects, except shortcut menus, custom toolbars and
startup settings. Can someone help me? How can I add shortcut menus,
custom toolbars, startup settings and Compact & Repair to the code to
create my backup and append the current date to the end of the file
name. Help on this would be appreciated.
Code:
=============================================
Sub BackupMyDatabase ()
' ==============================================
' Example code for ArchiveAccessObjects()
' ----------------------------------------------
' Makes archival copies of all objects in the
' current database to C:\BACKUPS\NWIND.MDB.
' ==============================================
Dim strBackup As String
Dim bOK As Boolean
strBackup = "C:\BACKUPS\NWIND.MDB"
bOK = ArchiveAccessObjects(strBackup, True)
If bOK Then
MsgBox "Database backed up successfully"
Else
Beep
MsgBox "Database was *not* backed up successfully"
End If
End Sub
' ==============================================
Function ArchiveAccessObjects(strArchiveDatabase As String,
bOverwriteNotify As Boolean) As Boolean
' Comments : creates archival copies of all objects in the current
database into a new database
' Parameters: strArchiveDatabase - name and path of the database to
archive to
' bOverwriteNotify - true to prompt if strArchiveDatabase already
exists. False otherwise.
' Returns : True if successful, False otherwise
'
Dim dbsCurrent As Database
Dim dbsOutput As Database
Dim intCounter As Integer
Dim strName As String
Dim bFileOK As Boolean
On Error GoTo err_ArchiveAccessObjects
bFileOK = True
' Check and handle for the file's existence
If FileExists(strArchiveDatabase) Then
bFileOK = False
If bOverwriteNotify Then
If MsgBox("Archive database " & strArchiveDatabase & " exists.
Overwrite?", vbQuestion + vbYesNo) = vbYes Then
bFileOK = True
Kill strArchiveDatabase
End If
Else
Kill strArchiveDatabase
bFileOK = True
End If
End If
If bFileOK Then
Set dbsCurrent = CurrentDb()
' Create the archive database and close it
Set dbsOutput = DBEngine.Workspaces(0).CreateDatabase(strArchiveDatabase,
dbLangGeneral)
dbsOutput.Close
' Export the tables
For intCounter = 0 To dbsCurrent.TableDefs.Count - 1
strName = dbsCurrent.TableDefs(intCounter).Name
' Don't export the system tables
If Left$(strName, 4) <> "MSys" Then
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acTable, strName, strName
End If
Next intCounter
' Export the queries
For intCounter = 0 To dbsCurrent.QueryDefs.Count - 1
strName = dbsCurrent.QueryDefs(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acQuery, strName, strName
Next intCounter
' Export the forms
For intCounter = 0 To dbsCurrent.Containers("Forms").Documents.Count -
1
strName = dbsCurrent.Containers("Forms").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acForm, strName, strName
Next intCounter
' Export the reports
For intCounter = 0 To dbsCurrent.Containers("Reports").Documents.Count
- 1
strName = dbsCurrent.Containers("Reports").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acReport, strName, strName
Next intCounter
' Export the macros
For intCounter = 0 To dbsCurrent.Containers("Scripts").Documents.Count
- 1
strName = dbsCurrent.Containers("Scripts").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acMacro, strName, strName
Next intCounter
' Export the modules
For intCounter = 0 To dbsCurrent.Containers("Modules").Documents.Count
- 1
strName = dbsCurrent.Containers("Modules").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acModule, strName, strName
Next intCounter
dbsCurrent.Close
End If
ArchiveAccessObjects = bFileOK
exit_ArchiveAccessObjects:
Exit Function
err_ArchiveAccessObjects:
ArchiveAccessObjects = False
Resume exit_ArchiveAccessObjects
End Function
' ==============================================
Function FileExists(strDest As String) As Boolean
' Comments : Determines if the named file exists
' Parameters: strDest - file to check
' Returns : True-file exists, false otherwise
'
Dim intLen As Integer
On Error Resume Next
intLen = Len(Dir(strDest))
FileExists = (Not Err And intLen > 0)
End Function
' ==============================================
Thanks,
PC
a database. I'm using A2K and it works when I set the references to
DAO. It creates archival copies of all objects in the current database
into a new database. This procedure uses the DAO CreateDatabase method
to create a new empty database. It then uses the TransferDatabase
action to copy all objects, except shortcut menus, custom toolbars and
startup settings. Can someone help me? How can I add shortcut menus,
custom toolbars, startup settings and Compact & Repair to the code to
create my backup and append the current date to the end of the file
name. Help on this would be appreciated.
Code:
=============================================
Sub BackupMyDatabase ()
' ==============================================
' Example code for ArchiveAccessObjects()
' ----------------------------------------------
' Makes archival copies of all objects in the
' current database to C:\BACKUPS\NWIND.MDB.
' ==============================================
Dim strBackup As String
Dim bOK As Boolean
strBackup = "C:\BACKUPS\NWIND.MDB"
bOK = ArchiveAccessObjects(strBackup, True)
If bOK Then
MsgBox "Database backed up successfully"
Else
Beep
MsgBox "Database was *not* backed up successfully"
End If
End Sub
' ==============================================
Function ArchiveAccessObjects(strArchiveDatabase As String,
bOverwriteNotify As Boolean) As Boolean
' Comments : creates archival copies of all objects in the current
database into a new database
' Parameters: strArchiveDatabase - name and path of the database to
archive to
' bOverwriteNotify - true to prompt if strArchiveDatabase already
exists. False otherwise.
' Returns : True if successful, False otherwise
'
Dim dbsCurrent As Database
Dim dbsOutput As Database
Dim intCounter As Integer
Dim strName As String
Dim bFileOK As Boolean
On Error GoTo err_ArchiveAccessObjects
bFileOK = True
' Check and handle for the file's existence
If FileExists(strArchiveDatabase) Then
bFileOK = False
If bOverwriteNotify Then
If MsgBox("Archive database " & strArchiveDatabase & " exists.
Overwrite?", vbQuestion + vbYesNo) = vbYes Then
bFileOK = True
Kill strArchiveDatabase
End If
Else
Kill strArchiveDatabase
bFileOK = True
End If
End If
If bFileOK Then
Set dbsCurrent = CurrentDb()
' Create the archive database and close it
Set dbsOutput = DBEngine.Workspaces(0).CreateDatabase(strArchiveDatabase,
dbLangGeneral)
dbsOutput.Close
' Export the tables
For intCounter = 0 To dbsCurrent.TableDefs.Count - 1
strName = dbsCurrent.TableDefs(intCounter).Name
' Don't export the system tables
If Left$(strName, 4) <> "MSys" Then
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acTable, strName, strName
End If
Next intCounter
' Export the queries
For intCounter = 0 To dbsCurrent.QueryDefs.Count - 1
strName = dbsCurrent.QueryDefs(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acQuery, strName, strName
Next intCounter
' Export the forms
For intCounter = 0 To dbsCurrent.Containers("Forms").Documents.Count -
1
strName = dbsCurrent.Containers("Forms").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acForm, strName, strName
Next intCounter
' Export the reports
For intCounter = 0 To dbsCurrent.Containers("Reports").Documents.Count
- 1
strName = dbsCurrent.Containers("Reports").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acReport, strName, strName
Next intCounter
' Export the macros
For intCounter = 0 To dbsCurrent.Containers("Scripts").Documents.Count
- 1
strName = dbsCurrent.Containers("Scripts").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acMacro, strName, strName
Next intCounter
' Export the modules
For intCounter = 0 To dbsCurrent.Containers("Modules").Documents.Count
- 1
strName = dbsCurrent.Containers("Modules").Documents(intCounter).Name
DoCmd.TransferDatabase acExport, "Microsoft Access",
strArchiveDatabase, acModule, strName, strName
Next intCounter
dbsCurrent.Close
End If
ArchiveAccessObjects = bFileOK
exit_ArchiveAccessObjects:
Exit Function
err_ArchiveAccessObjects:
ArchiveAccessObjects = False
Resume exit_ArchiveAccessObjects
End Function
' ==============================================
Function FileExists(strDest As String) As Boolean
' Comments : Determines if the named file exists
' Parameters: strDest - file to check
' Returns : True-file exists, false otherwise
'
Dim intLen As Integer
On Error Resume Next
intLen = Len(Dir(strDest))
FileExists = (Not Err And intLen > 0)
End Function
' ==============================================
Thanks,
PC