Function DatabaseCompact(sDatabasePath As String, Optional bEncryptDatabase As Boolean = False) As Long Dim oJRO As Object 'JRO.JetEngine On Error GoTo ErrFailed If Len(Dir$(sDatabasePath & ".tmp")) Then 'Delete the existing temp database VBA.Kill sDatabasePath & ".tmp" End If Set oJRO = CreateObject("JRO.JetEngine") If bEncryptDatabase Then 'Compact and encrypt the database oJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath & ".tmp;Jet OLEDB:Encrypt Database=True" Else 'Compact the database oJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath & ".tmp;Jet OLEDB:Engine Type=4" End If 'Delete the existing database VBA.Kill sDatabasePath 'Rename the compacted database Name sDatabasePath & ".tmp" As sDatabasePath Set oJRO = Nothing Exit Function ErrFailed: Debug.Print "Failed to compact database: " & Err.Description DatabaseCompact = Err.Number Set oJRO = Nothing On Error GoTo 0 End Function 'Demonstration routine Sub Test() Dim lRes As Long On Error Resume Next lRes = DatabaseCompact("C:\test.mdb", True) If lRes = 0 Then MsgBox "Succeeded in compacting database...", vbInformation Else 'Show error message MsgBox Error(lRes) End If Exit Sub ErrFailed: MsgBox Err.Description End Sub