Access Automation – VBA compact current database

[carlmack]

For some time on this forum we have assumed that the only VBA way to compact and repair an Access database is from outside the current db. With Access often you need to run a compact as a daily routine which meant that you needed to have code somewhere, which compacted the first db to a second db, deleted the first, then renamed the second to the first.

This code (source vangelos) compacts the current db with one line.

Public Sub CompactDB()
CommandBars("Menu Bar").Controls("Tools").Controls("Database utilities").Controls("Compact and repair database...").accDoDefaultAction
End Sub

The below code (and attached) performs the old operation but also takes five rolling backups of the database.

This db is only used as a VBA holder there is no data in it. If you download the file open it with the shift key held down to stop it running automatically. It contains a form which is set as the start form. The form has an on open event that runs a macro and the macro runs a defined function that runs the code. You don’t need the macro bit but hopefully it demonstrates the possibilities. You can use this with a simple Windows Schedule that opens the db (the run line in Windows just needs the path to the db).

Sub CompactDbase()
     ' Requires a reference to be set to
     ' "Microsoft Jet & Replication Objects Library 2.x"
     ' (Tools > References and check the reference)
     ' Requires a form called "startup" with a label called "ProgressLabel"
    On Error GoTo ErrHandler
    
    ' Inform user of progress
    Form_StartUp.ProgressLabel.Caption = "Starting Process"
    DoEvents
    
    ' dimension variables and set
    Dim DbaseDir As String
    Dim BackupDir As String
    Dim DbaseName As String
    Dim DbaseTempName As String
    Dim DbaseBackupName As String
    Dim Dbasebk1 As String
    Dim Dbasebk2 As String
    Dim Dbasebk3 As String
    Dim Dbasebk4 As String
    Dim Dbasebk5 As String
    
    ' CHANGE SETTINGS IN THIS SECTION TO REUSE THIS PROGRAM
    ' ###########################################################
    DbaseDir = "C:\Database\"
    BackupDir = "C:\DbaseBackup\"
    DbaseName = "XXX.mdb"
    DbaseTempName = "XXXTemp.mdb"
    DbaseBackupName = "XXXBackup.mdb"
    Dbasebk1 = "XXX1.mdb"
    Dbasebk2 = "XXX2.mdb"
    Dbasebk3 = "XXX3.mdb"
    Dbasebk4 = "XXX4.mdb"
    Dbasebk5 = "XXX5.mdb"
    ' ###########################################################
    Form_StartUp.ProgressLabel.Caption = "Initial Backup started. " & DbaseBackupName
    DoEvents
    ' Perform Backup before starting
    FileCopy DbaseDir & DbaseName, _
        DbaseDir & DbaseBackupName
    
    Dim je As New JRO.JetEngine
    
    ' Kill previous Temp file
    If Dir(DbaseDir & DbaseTempName) <> "" Then _
        Kill DbaseDir & DbaseTempName
     
     ' Compact dbase to dbaseTemp
    Form_StartUp.ProgressLabel.Caption = "Compacting started. " & DbaseTempName
    DoEvents
    je.CompactDatabase _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & DbaseDir & DbaseName, _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & DbaseDir & DbaseTempName & ";"
    
    ' Delete dbase
    Form_StartUp.ProgressLabel.Caption = "Replacing compact file " & DbaseName
    DoEvents
    Kill DbaseDir & DbaseName
    
    ' Rename dbaseTemp (now compacted) to dbase
    Name DbaseDir & DbaseTempName _
        As DbaseDir & DbaseName

    ' Resuffle backups and backup current
    Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk5
    DoEvents
    If Dir(BackupDir & Dbasebk5) <> "" Then
        Kill BackupDir & Dbasebk5
    End If
    Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk4
    DoEvents
    If Dir(BackupDir & Dbasebk4) <> "" Then
        Name BackupDir & Dbasebk4 _
        As BackupDir & Dbasebk5
    End If
    Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk3
    DoEvents
    If Dir(BackupDir & Dbasebk3) <> "" Then
        Name BackupDir & Dbasebk3 _
        As BackupDir & Dbasebk4
    End If
    Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk2
    DoEvents
    If Dir(BackupDir & Dbasebk2) <> "" Then
        Name BackupDir & Dbasebk2 _
        As BackupDir & Dbasebk3
    End If
    Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk1
    DoEvents
    If Dir(BackupDir & Dbasebk1) <> "" Then
        Name BackupDir & Dbasebk1 _
        As BackupDir & Dbasebk2
    End If

        
    FileCopy DbaseDir & DbaseName, _
        BackupDir & Dbasebk1
     Form_StartUp.ProgressLabel.Caption = "Process info"
     DoEvents
    Exit Sub
    
ErrHandler:
MsgBox ("Error message here - Your first time ? Did you forget to hold down shift key ?")
End Sub

Public Function CompactBackupdbase()
' Allows sub to be visible from macros
Call CompactDbase
End Function

With the new command (compact the current database) you would just need to create a macro to run the one line of code. To run the macro directly from Windows Scheduler you need a more complex run line in Windows eg.

"C:\Program Files\Microsoft Office\Office10\MSACCESS.EXE" E:\Database\YourDatabaseName.mdb /x Combined YourMacroName

Carl