Modules: VB5 Compact Database utility (Access 97)

INFORMATION PROVIDED IN THIS DOCUMENT AND THE MDBSHELL UTILITY ARE PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED. THE USER ASSUMES THE ENTIRE RISK OF RUNNING THIS SOFTWARE.

Ó Dev Ashish (1998), All Rights Reserved

   Here's a VB5 utility that lets you compact the current database from code within an Access 97 database.

  Download mdbCompact.zip (9,454 bytes)

[ Also see Compactor Addin ]

As with any app's version 1.0, mdbCompact might also have bugs in it.  I've tested this both under NT 4 and Win95.  But if you encounter any bugs or have any suggestions,  please email them to me.

In order to run the mdbComact utility,  you must have either VB5 installed on your pc or have the runtime files.  If you don't have VB 5, you can download the runtime files needed to run this utility from Microsoft.

    To use the utility, pass the Currentdb.Name as a command line argument to it from code.

'******************** Code Begin ****************
Sub sTestmdbCompact()
Dim x
Dim strFolder As String
    strFolder = CurrentDBDir
    x = Shell(strFolder & "mdbCompact.exe " & CurrentDb.Name, vbNormalFocus)
End Sub

'Code courtesy of
'Terry Kreft
Function CurrentDBDir() As String
Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    CurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
'******************** Code End ****************

The code in the VB5 app itself is straight forward.  Here's what happens in the background.

'******************** Code Begin ****************
'This code was originally written by Dev Ashish
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Dev Ashish
'
Option Explicit
Private Const mcFILENOTEXIST = vbObjectError + 10
Private Const mcACCESSNOTRUNNING = vbObjectError + 20
Private Const mcNOCOMMANDLINE = vbObjectError + 30
Private Const mcSave = 1

Private mobjAccess As Object

Private Sub Form_Load()
Dim stmdbName As String
Dim stMsg As String
Dim stNewName As String
Dim stTmp As String, stFileOnly As String

    On Error GoTo PROC_ERR
    stmdbName = Command
    stFileOnly = Dir(stmdbName)
    If stmdbName = vbNullString Then Err.Raise mcNOCOMMANDLINE
    If Len(Dir(stmdbName)) = 0 Then Err.Raise mcFILENOTEXIST
    If Not fIsAppRunning("Access") Then Err.Raise mcACCESSNOTRUNNING
    
    Load frmWait
    frmWait.Visible = True
    frmWait.lblStatus.Caption = "Compacting " & stFileOnly & "....."
    frmWait.Refresh
    
    Set mobjAccess = GetObject(, "Access.Application.8")
    
    stNewName = TempFile(False)
    With mobjAccess.application
        Call sCloseAllObjects
        .CloseCurrentDatabase
        DoEvents
        DBEngine.CompactDatabase stmdbName, stNewName
        DoEvents
        Kill stmdbName
        DoEvents
        FileCopy stNewName, stmdbName
        Do While Len(stmdbName) = 0: DoEvents:  Loop
        .opencurrentdatabase stmdbName
        Kill stNewName
    End With

PROC_EXIT:
    Set mobjAccess = Nothing
    Unload frmWait
    Unload Me
  Exit Sub
  
PROC_ERR:
    Select Case Err
        Case mcNOCOMMANDLINE:
            stMsg = "Missing Command Line.  Terminating!"
            MsgBox stMsg, vbCritical + vbOKOnly, "No mdb name found!"
        Case mcFILENOTEXIST:
            stMsg = "The filename you specified" & vbCrLf
            stMsg = stMsg & stmdbName & vbCrLf
            stMsg = stMsg & "doesn't exist.  Please  check the filename and try again!"
            MsgBox stMsg, vbCritical + vbOKOnly, "File not found"
            
        Case mcACCESSNOTRUNNING:
            stMsg = "The mdbCompact utility requires Access to be running!"
            stMsg = stMsg & vbCrLf & _
                "Please confirm that Access is currently running and try again."
            MsgBox stMsg, vbExclamation + vbOKOnly, "Access instance not found"
        
        Case 429:
            stMsg = "The mdbCompact utility couldn't locate Access instance!"
            MsgBox stMsg, vbExclamation + vbOKOnly, "Access instance not found"
                
        Case Else:
            MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
                "Unknown Error"
    End Select
  Resume PROC_EXIT
End Sub

Sub sCloseAllObjects()
Dim i As Integer, ctr As Object, j As Integer
Dim db As Object
Dim astObj(0 To 5) As String
    astObj(0) = "Tables"
    astObj(1) = "Queries"
    astObj(2) = "Forms"
    astObj(3) = "Reports"
    astObj(4) = "Scripts"
    astObj(5) = "Modules"
    On Error Resume Next
    With mobjAccess
        Set db = .currentdb
        For i = 0 To 5
            Set ctr = db.Containers(astObj(i))
            For j = 0 To ctr.Documents.Count - 1
                .DoCmd.Close i, ctr.Documents(j).Name, mcSave
            Next j
        Next i
    End With
End Sub
'******************** Code End ****************