MS Access: how to compact current database in VBA

Question

Pretty simple question, I know.

Answer 1

Try adding this module, pretty simple, just launches Access, opens the database, sets the "Compact on Close" option to "True", then quits.

Syntax to auto-compact:

acCompactRepair "C:\Folder\Database.accdb", True

To return to default*:

acCompactRepair "C:\Folder\Database.accdb", False

*not necessary, but if your back end database is >1GB this can be rather annoying when you go into it directly and it takes 2 minutes to quit!

EDIT: added option to recurse through all folders, I run this nightly to keep databases down to a minimum.

'accCompactRepair
'v2.02 2013-11-28 17:25

'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   TJP@tomparish.me.uk
'   http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'includes code from
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for improved error handling

'   v2.02   bugfix preventing Compact when bAutoCompact set to False
'           bugfix with "OLE waiting for another application" msgbox
'           added "MB" to start & end sizes of message box at end
'   v2.01   added size reduction to message box
'   v2.00   added recurse
'   v1.00   original version

Option Explicit

Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _
    , Optional bAutoCompact As Boolean = False) As String
'v2.02 2013-11-28 17:25
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True

'syntax:
'   accSweepForDatabases "path", [False], [True]

'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":
'   accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]

Application.DisplayAlerts = False

Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single
Dim SizeBefore As Long, SizeAfter As Long
t = Timer
RecursiveDir colFiles, strFolder, "*.accdb", True  'comment this out if you only have Access 2003 installed
RecursiveDir colFiles, strFolder, "*.mdb", True

    For Each vFile In colFiles
        'Debug.Print vFile
        SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)
On Error GoTo CompactFailed
    If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"
        acCompactRepair vFile, bAutoCompact
        i = i + 1  'counts successes
        GoTo NextCompact
CompactFailed:
On Error GoTo 0
        j = j + 1   'counts failures
        sFails = sFails & vFile & vbLf  'records failure
NextCompact:
On Error GoTo 0
        SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)

    Next vFile

Application.DisplayAlerts = True

'display message box, mark end of process
    accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"
    If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails
    MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"

End Function

Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean
'v2.02 2013-11-28 16:22
'if doEnable = True will compact and repair pthfn
'if doEnable = False will then disable auto compact on pthfn

On Error GoTo CompactFailed

Dim A As Object
Set A = CreateObject("Access.Application")
With A
    .OpenCurrentDatabase pthfn
    .SetOption "Auto compact", True
    .CloseCurrentDatabase
    If doEnable = False Then
        .OpenCurrentDatabase pthfn
        .SetOption "Auto compact", doEnable
    End If
    .Quit
End With
Set A = Nothing
acCompactRepair = True
Exit Function
CompactFailed:
End Function


'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for error handling

Private Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
On Error Resume Next
    strTemp = ""
    strTemp = Dir(strFolder & strFileSpec)
On Error GoTo 0
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
On Error Resume Next
        strTemp = ""
        strTemp = Dir(strFolder, vbDirectory)
On Error GoTo 0
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function