VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCompactDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' *****************************************************************************
' clsCompactMDB.cls
' By HardCode
' 9-5-2003
'
' Just pass a fully qualified path to a .mdb file and the class will
' compact the database.
' *****************************************************************************

Option Explicit

Private sDatabase       As String


Public Property Get Database() As String
    Database = sDatabase
End Property

Public Property Let Database(psDatabase As String)
    sDatabase = psDatabase
End Property

Public Function CompactDatabase() As Boolean
 On Error GoTo ErrorHandler
 
 Dim wrkJet             As Workspace
 Dim oDatabase          As DAO.Database
 Dim oDBEngine          As DAO.DBEngine
 Dim sTempDBName        As String
 Dim DBName             As String
 Dim DBPath             As String
 Dim lBackslashPos      As Long
 Dim oFSO               As Scripting.FileSystemObject
    
    ' Find the last "\" to parse out file name from the path.
    lBackslashPos = InStrRev(sDatabase, "\", -1)
    ' Get the file name.
    DBName = Mid(sDatabase, lBackslashPos + 1)
    ' Get the path (folder)
    DBPath = Left(sDatabase, lBackslashPos)
    
    ' Add in "Temp" to the file name because function CompactDatabase
    ' requires you to compact a COPY of the database. The compacted
    ' DB will be renamed later.
    sTempDBName = Left(sDatabase, Len(sDatabase) - 4) & "-TEMP.mdb"
    
    ' Create Microsoft Jet Workspace object.
    Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
    
    ' Create a DBEngine, compact the DB, and destroy objects
    Set oDBEngine = New DAO.DBEngine
    DoEvents
    oDBEngine.CompactDatabase sDatabase, sTempDBName
    Set oDBEngine = Nothing
    wrkJet.Close
    Set wrkJet = Nothing
    
    ' Now, delete the uncompacted DB, copy the compacted DB with the original
    ' name, and then delete the "...-Temp.mdb"
    Set oFSO = New Scripting.FileSystemObject
    oFSO.DeleteFile sDatabase
    oFSO.CopyFile sTempDBName, sDatabase
    oFSO.DeleteFile sTempDBName
    Set oFSO = Nothing
    
    CompactDatabase = True
 
ExitHandler:
    Exit Function
    
ErrorHandler:
    MsgBox "Error compacting database " & sDatabase & ". Please contact the IT department.", vbCritical, "Compact " & sDatabase
    CompactDatabase = False

End Function