Source

VB and VBA Code Library / clsRepairAndCompactMDB.cls

Full commit
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRepairAndCompactMDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''
' Class "Repair and Compact MDB"
'
' @author   Christoph Juengling <christoph@juengling-edv.de>
' @remarks  Uses "Microsoft Jet and Replication Objects 2.x Library"
' @link   https://bitbucket.org/juengling/vb-and-vba-code-library
'
Option Explicit

Public Event Started()
Public Event Compacting()
Public Event CleaningUp()
Public Event MakeBackup()
Public Event FileAlreadyExists(ByRef Cancel As Boolean)
Public Event Finished()

Private m_strDatabasePath As String
Private sTempDBPath As String
Private sBackupDBPath As String

''
' Compact Access Database
'
Public Sub CompactDB()

Const FUNCTION_NAME = "CompactDB"

Dim con As JRO.JetEngine
Dim es As tSavedError

'------------------------

On Error GoTo Catch

RaiseEvent Started
DatabasePath = Trim(DatabasePath)
If DatabasePath = "" Then RaiseProjectError ERR_WRONG_PATH, , , "The path to the database is empty."
If Not FileExists(DatabasePath) Then RaiseProjectError ERR_WRONG_PATH, , , "The database to compact doesn't exist."

' Delete temporary file, if still existing
RaiseEvent CleaningUp
DeleteFile sTempDBPath
DeleteFile sBackupDBPath

' Ensure file is not read only
SetAttr DatabasePath, vbNormal

RaiseEvent MakeBackup
FileCopy DatabasePath, sBackupDBPath

' Do the work here
RaiseEvent Compacting
Set con = New JRO.JetEngine
con.CompactDatabase GetConnectString(DatabasePath), GetConnectString(sTempDBPath)

' Copy the repaired database to the original place
RaiseEvent CleaningUp
DeleteFile DatabasePath
FileCopy sTempDBPath, DatabasePath
DeleteFile sTempDBPath
DeleteFile sBackupDBPath

'------------------------
Final:
On Error Resume Next
Set con = Nothing

On Error GoTo 0
RaiseSavedError es
RaiseEvent Finished
Exit Sub

'------------------------
Catch:
es = SaveError(typeName(Me), FUNCTION_NAME, Erl)
Select Case es.Number
    Case GetVBErrorNumber(ERR_ABORTED)
        es.Source = typeName(Me)
        
    Case Else
        Debug.Print es.Number, es.Source, es.Description
End Select
Resume Final
Resume ' for test purposes only

End Sub

Private Sub Class_Initialize()

DatabasePath = ""
sTempDBPath = GetTempPath() & "DCU-ICE-Temp.mdb"

End Sub


''
' Get Windows' temporary path
'
' @return   Temporary path with trailing backslash
'
Private Function GetTempPath() As String
    
Dim oFS As FileSystemObject
Dim sResult As String

'------------------------------
    
Set oFS = New FileSystemObject
sResult = oFS.GetSpecialFolder(Scripting.TemporaryFolder)
If Right(sResult, 1) <> "\" Then sResult = sResult & "\"
Set oFS = Nothing

GetTempPath = sResult

End Function




''
' Get connect string to MDB
'
' @param    Filename   Filename/Path to MDB
' @return   ADO connect string
'
Private Function GetConnectString(filename As String) As String

GetConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filename & ";"

' Evtl. erg�nzen:
'Jet OLEDB:Engine Type=5;

End Function


''
' Check if file exists or not
'
' @param    Path   Description1
' @return   TRUE = file exists, FALSE = file doesn't exist
'
Private Function FileExists(path As String) As Boolean

FileExists = (Dir(path) <> "")

End Function

Public Property Get DatabasePath() As String

DatabasePath = m_strDatabasePath

End Property

Public Property Let DatabasePath(ByVal strDatabasePath As String)

m_strDatabasePath = strDatabasePath
sBackupDBPath = strDatabasePath & ".bak"

End Property


''
' Delete a file
'
' @param    Path   Path to the file to be deleted
' @remarks  Raise event to give calling process possibility to abort
'
Private Sub DeleteFile(path As String)

Const FUNCTION_NAME = "DeleteFile"

Dim Cancel As Boolean
Dim es As tSavedError

'------------------------

On Error GoTo Catch

If FileExists(path) Then
    Cancel = False
    RaiseEvent FileAlreadyExists(Cancel)
    If Cancel Then
        RaiseProjectError ERR_ABORTED, typeName(Me), FUNCTION_NAME, "Function aborted"
    Else
        Kill path
    End If
End If

'------------------------
Final:
On Error GoTo 0
RaiseSavedError es
Exit Sub

'------------------------
Catch:
es = SaveError(typeName(Me), FUNCTION_NAME, Erl)
Select Case es.Number
    Case Else
        Debug.Print es.Number, es.Source, es.Description
End Select
Resume Final
Resume ' for test purposes only

End Sub