MS Access: how to compact current database in VBA

If you want to compact/repair an external mdb file (not the one you are working in just now):

Application.compactRepair sourecFile, destinationFile

If you want to compact the database you are working with:

Application.SetOption "Auto compact", True

In this last case, your app will be compacted when closing the file.

My opinion: writting a few lines of code in an extra MDB "compacter" file that you can call when you want to compact/repair an mdb file is very usefull: in most situations the file that needs to be compacted cannot be opened normally anymore, so you need to call the method from outside the file.

Otherwise, the autocompact shall by default be set to true in each main module of an Access app.

In case of a disaster, create a new mdb file and import all objects from the buggy file. You will usually find a faulty object (form, module, etc) that you will not be able to import.

If you have the database with a front end and a back end. You can use the following code on the main form of your front end main navigation form:

Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As StringDim s1 As Long, s2 As LongsDataFile = "C:\MyDataFile.mdb"sDataFileTemp = "C:\MyDataFileTemp.mdb"sDataFileBackup = "C:\MyDataFile Backup " & Format(Now, "YYYY-MM-DD HHMMSS") & ".mdb"DoCmd.Hourglass True'get file size before compactOpen sDataFile For Binary As #1s1 = LOF(1)Close #1'backup data fileFileCopy sDataFile, sDataFileBackup'only proceed if data file existsIf Dir(sDataFileBackup vbNormal) <> "" Then        'compact data file to temp file        On Error Resume Next        Kill sDataFileTemp        On Error GoTo 0        DBEngine.CompactDatabase sDataFile, sDataFileTemp        If Dir(sDataFileTemp, vbNormal) <> "" Then            'delete old data file data file            Kill sDataFile            'copy temp file to data file            FileCopy sDataFileTemp, sDataFile            'get file size after compact            Open sDataFile For Binary As #1            s2 = LOF(1)            Close #1            DoCmd.Hourglass False            MsgBox "Compact complete " & vbCrLf & vbCrLf _                & "Size before: " & Round(s1 / 1024 / 1024, 2) & "Mb" & vbCrLf _                & "Size after:    " & Round(s2 / 1024 / 1024, 2) & "Mb", vbInformation        Else            DoCmd.Hourglass False            MsgBox "ERROR: Unable to compact data file"        End IfElse        DoCmd.Hourglass False        MsgBox "ERROR: Unable to backup data file"End IfDoCmd.Hourglass False

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 versionOption ExplicitFunction 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 = FalseDim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As SingleDim SizeBefore As Long, SizeAfter As Longt = TimerRecursiveDir colFiles, strFolder, "*.accdb", True  'comment this out if you only have Access 2003 installedRecursiveDir 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 NextCompactCompactFailed:On Error GoTo 0        j = j + 1   'counts failures        sFails = sFails & vFile & vbLf  'records failureNextCompact:On Error GoTo 0        SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)    Next vFileApplication.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 FunctionFunction 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 pthfnOn Error GoTo CompactFailedDim A As ObjectSet 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    .QuitEnd WithSet A = NothingacCompactRepair = TrueExit FunctionCompactFailed:End Function'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html'tweaked slightly for error handlingPrivate 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 strFolderOn 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 IfEnd FunctionPrivate 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 IfEnd Function