Compact Access Database with ADO

[Armbruster]

I've seen this one asked quite a bit. Contrary to popular belief, you don't need to use archaic DAO to compact an Access database . . .

I didn't document this code tremendously, I think it is pretty easy to follow.

' On a form
 
Option Explicit
 
Private Sub Command1_Click()
    Dim sSource As String
    Dim sDest As String
 
    sSource = App.Path & "\Northwind.MDB"
    sDest = App.Path & "\CompactNwind.MDB"
 
    If CompactDB(sSource, sDest) Then
        MsgBox "Compact complete"
    End If
    
End Sub
 
' In a module
 
Option Explicit
 
'From MSDN . . .
'-----------------------------------------------
'Jet OLEDB:Engine Type  Jet x.x Format MDB Files
'---------------------  ------------------------
'       1                     JET10
'       2                     JET11
'       3                     JET2X
'       4                     JET3X
'       5                     JET4X
'-----------------------------------------------
 
Public Function CompactDB(ByVal sSource As String, ByVal sDest As String) As Boolean
    'Requires references to:
    ' Microsoft Jet and Replication Objects 2.1 Library (or higher)
    ' Microsoft ActiveX Data Objects 2.5 Library (or higher)
    Dim iEngineType As Integer
    Dim jro As jro.JetEngine
    Dim cn As ADODB.Connection
 
   On Error GoTo CompactDB_Error
    
    sSource = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & sSource
    
    ' Find the engine type to use when compacting database
    Set cn = New ADODB.Connection
    With cn
        .Open sSource
       iEngineType = .Properties("Jet OLEDB:Engine Type")
       .Close
    End With
    Set cn = Nothing
    
    sDest = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
               "Jet OLEDB:Engine Type=" & iEngineType & _
               ";Data Source=" & sDest
    
    Set jro = New jro.JetEngine
    jro.CompactDatabase sSource, sDest
    CompactDB = True
    Set jro = Nothing
 
On Error GoTo 0
Exit Function
CompactDB_Error:
    CompactDB = False
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CompactDB of Module Module1"
    ' Clean up any "junk" left behind
On Error Resume Next
    Set cn = Nothing
    Set jro = Nothing
On Error GoTo 0
End Function