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. 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 the objects. Can someone help me? How can I add Compact & Repair to the code to create my backup? Also I would like to 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

 

[simon162]

Archiving Solution

Hello,

Iam from Pressmart, media service company and we offer digital publishing and archiving soultions to publications.

If you are Looking to transform documents into intelligent content to reach global audience then try pressmart.net

Discuss more with me

 

[ted.martin]

This should do it

Application.SetOption ("Auto Compact"), 1
Application.SetOption "Show Status Bar", True
vStatusBar = SysCmd(acSysCmdSetStatus, "The application is being compacted!")