Archiving A Database

[PC User]

I have this code from a db of a previous version of access to archive
a database, but I'm using A2K and it doesn't seem to work. Can
someone help me?

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(strArchiveDa tabase,
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(intCounte r).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(intCoun ter).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(intCoun ter).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(intCoun ter).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

[Alan Webb]

PC User,
This seems to be written against DAO. Check your libraries and make sure
that DAO is enabled for the VB Project containing the code. One comment
about the code itself: I'd change it so the destination of the backup can be
selected by the user. And . . . You can use Compact and Repair to create a
copy of an Access mdb. Were I writing something like this I'd probably use
Compact & Repair to create my backup.

"PC User" <pc*****@SoftHome.net> wrote in message
news:25**************************@posting.google.c om...

I have this code from a db of a previous version of access to archive
a database, but I'm using A2K and it doesn't seem to work. Can
someone help me?

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(strArchiveDa tabase,
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(intCounte r).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(intCoun ter).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(intCoun ter).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(intCoun ter).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

[PC User]

It works now that I've referenced DAO. 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.

Thanks,
PC