View Single Post
  #2 (permalink)  
Old August 6th, 2004, 10:46 AM
Bob Bedell Bob Bedell is offline
Friend of Wrox
Join Date: Jun 2003
Location: , , USA.
Posts: 1,093
Thanks: 1
Thanked 12 Times in 11 Posts

Hi Tasha,

Here's a standard DAO routine to compact a Jet database from code. Don't think it will help you if the db is already open, but it might give you some ideas.

Function CompactDb(strDbPath As String) As Boolean
    ' This procedure creates a backup copy of a database
    ' and then compacts it.
    ' Arguments:
    ' strDbPath: The path to the database to be compacted.
    ' Returns:
    ' A Boolean value indicating success or failure.

    Dim dbs As Database
    Dim intLength As Integer
    Dim varPosition As Variant
    Dim strDbTemp As String, strDbCompacted As String
    Dim strDbBackup As String
    Dim strMsg As String
    Const conPermissionDenied As Integer = 70

    On Error GoTo Err_CompactDb
    ' Initialize string for message.
    strMsg = "Database " & strDbPath & " cannot be opened exclusively. " _
        & "The database may have already been opened by you or another user."

    ' Compact the database to a temporary file.
    intLength = Len(strDbPath)
    varPosition = InStr(strDbPath, ".mdb")
    If varPosition > 0 Then
        strDbTemp = Left(strDbPath, varPosition - 1)

        ' Create backup file before compacting.
        strDbBackup = strDbTemp & ".bak"
        FileCopy strDbPath, strDbBackup

        ' Check whether database can be opened exclusively.
        ' This line calls a function defined in Chapter 2.
        If Not CanOpenDbExclusively(strDbPath) Then
            MsgBox strMsg
            GoTo Exit_CompactDb
        End If

        ' Compact to new file.
        strDbCompacted = strDbTemp & "Compacted.mdb"
        DBEngine.CompactDatabase strDbPath, strDbCompacted

        ' Delete uncompacted database.
        Kill strDbPath

        ' Rename compacted database to original name.
        Name strDbCompacted As strDbPath
    End If
    CompactDb = True

    On Error Resume Next
    Set dbs = Nothing
    Exit Function

    If Err = conPermissionDenied Then
        MsgBox strMsg
        MsgBox "Error " & Err & ": " & vbCrLf & Err.Description
    End If
    CompactDb = False
    Resume Exit_CompactDb
End Function



Reply With Quote