I did this many years back on 2003 or possibly 97, yikes!
If I recall you need to use one of the subcommands above tied to a timer. You cannot operate on the db with any connections or forms open.
So you do something about closing all forms, and kick off the timer as the last running method. (which will in turn call the compact operation once everything closes)
If you haven't figured this out I could dig through my archives and pull it up.
DBEngine.CompactDatabase source, dest
Try this. It works on the same database in which the code resides. Just call the CompactDB() function shown below. Make sure that after you add the function, you click the Save button in the VBA Editor window prior to running for the first time. I only tested it in Access 2010. Ba-da-bing, ba-da-boom.
Public Function CompactDB()
Dim strWindowTitle As String
On Error GoTo err_Handler
strWindowTitle = Application.Name & " - " & Left(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4)
strTempDir = Environ("Temp")
strScriptPath = strTempDir & "\compact.vbs"
strCmd = "wscript " & """" & strScriptPath & """"
Open strScriptPath For Output As #1
Print #1, "Set WshShell = WScript.CreateObject(""WScript.Shell"")"
Print #1, "WScript.Sleep 1000"
Print #1, "WshShell.AppActivate " & """" & strWindowTitle & """"
Print #1, "WScript.Sleep 500"
Print #1, "WshShell.SendKeys ""%yc"""
Close #1
Shell strCmd, vbHide
Exit Function
err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Close #1
End Function
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 String
Dim s1 As Long, s2 As Long
sDataFile = "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 compact
Open sDataFile For Binary As #1
s1 = LOF(1)
Close #1
'backup data file
FileCopy sDataFile, sDataFileBackup
'only proceed if data file exists
If 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 If
Else
DoCmd.Hourglass False
MsgBox "ERROR: Unable to backup data file"
End If
DoCmd.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
' [email protected]
' 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
If you don't wish to use compact on close (eg, because the front-end mdb is a robot program that runs continually), and you don't want to create a separate mdb just for compacting, consider using a cmd file.
I let my robot.mdb check its own size:
FileLen(CurrentDb.Name))
If its size exceeds 1 GB, it creates a cmd file like this ...
Dim f As Integer
Dim Folder As String
Dim Access As String
'select Access in the correct PF directory (my robot.mdb runs in 32-bit MSAccess, on 32-bit and 64-bit machines)
If Dir("C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE") > "" Then
Access = """C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE"""
Else
Access = """C:\Program Files\Microsoft Office\Office\MSACCESS.EXE"""
End If
Folder = ExtractFileDir(CurrentDb.Name)
f = FreeFile
Open Folder & "comrep.cmd" For Output As f
'wait until robot.mdb closes (ldb file is gone), then compact robot.mdb
Print #f, ":checkldb1"
Print #f, "if exist " & Folder & "robot.ldb goto checkldb1"
Print #f, Access & " " & Folder & "robot.mdb /compact"
'wait until the robot mdb closes, then start it
Print #f, ":checkldb2"
Print #f, "if exist " & Folder & "robot.ldb goto checkldb2"
Print #f, Access & " " & Folder & "robot.mdb"
Close f
... launches the cmd file ...
Shell ExtractFileDir(CurrentDb.Name) & "comrep.cmd"
... and shuts down ...
DoCmd.Quit
Next, the cmd file compacts and restarts robot.mdb.
When the user exits the FE attempt to rename the backend MDB preferably with todays date in the name in yyyy-mm-dd format. Ensure you close all bound forms, including hidden forms, and reports before doing this. If you get an error message, oops, its busy so don't bother. If it is successful then compact it back.
See my Backup, do you trust the users or sysadmins? tips page for more info.
Check out this solution VBA Compact Current Database.
Basically it says this should work
Public Sub CompactDB()
CommandBars("Menu Bar").Controls("Tools").Controls ("Database utilities"). _
Controls("Compact and repair database...").accDoDefaultAction
End Sub
For Access 2013, you could just do
Sendkeys "%fic"
This is the same as typing ALT, F, I, C on your keyboard.
It's probably a different sequence of letters for different versions, but the "%" symbol means "ALT", so keep that in the code. you may just need to change the letters, depending on what letters appear when you press ALT
Yes it is simple to do.
Sub CompactRepair()
Dim control As Office.CommandBarControl
Set control = CommandBars.FindControl( Id:=2071 )
control.accDoDefaultAction
End Sub
Basically it just finds the "Compact and repair" menuitem and clicks it, programatically.
There's also Michael Kaplan's SOON ("Shut One, Open New") add-in. You'd have to chain it, but it's one way to do this.
I can't say I've had much reason to ever want to do this programatically, since I'm programming for end users, and they are never using anything but the front end in the Access user interface, and there's no reason to regularly compact a properly-designed front end.
Application.SetOption "Auto compact", False '(mentioned above) Use this with a button caption: "DB Not Compact On Close"
Write code to toggle the caption with "DB Compact On Close" along with Application.SetOption "Auto compact", True
AutoCompact can be set by means of the button or by code, ex: after importing large temp tables.
The start up form can have code that turns off Auto Compact, so that it doesn't run every time.
This way, you are not trying to fight Access.
Source: Stackoverflow.com