By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,466 Members | 1,772 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,466 IT Pros & Developers. It's quick & easy.

Archiving A Database

P: n/a
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
Nov 13 '05 #1
Share this Question
Share on Google+
2 Replies


P: n/a
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

Nov 13 '05 #2

P: n/a
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
Nov 13 '05 #3

This discussion thread is closed

Replies have been disabled for this discussion.