Compact a JET database using ADO in VB6

6:21 PM Unknown 0 Comments

The following routines demonstrates how to compact a JET database using ADO:

Option Explicit

'Purpose     :  Compact a JET (Access) database using ADO
'Inputs      :  sDatabasePath                   The path to the database path eg. C:\nwind.mdb
'               [bEncryptDatabase]              If True, encrypts the contents of the database
'Outputs     :  Returns zero if successful, else returns error code
'Notes       :  Requires "Microsoft Jet and Replication Objects X.X library",
'               where (X.X is greater than or equal to 2.1)
'               Compacts the database by creating a temporary database with the extension .tmp then,
'               if the compaction is successful, it overwrites the original database.
'               Will not work if anyone else is connected to the database.
'Revisions   :
'Assumptions :

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