Option Explicit
Option Compare Database
'--------------------------------------------------------------------------------------------------------------
' Primary Objects, Methods, and Properties:
'
' MC_CompactDB : This class. Handles the compacting itself. Acts as a factory class to assist in
' creating sister class MC_DB objects (individual databases to be compacted).
'
' MC_DB : Database Object defined by sister class MC_DB with the following properties
' DBPath - location of the database to be compacted
' BackupFolder - Name of a folder for storing backups.
' BackupRetention - Number of backups to keep (default = 3)
' LogFilePath - Log File Path
' AttemptToDeleteLockFile - if a lock file exists and this argument is true,
' the procedure will try to delete a lock file.
' this is useful when an orphan lock file remains
' from an improper shutdown.
'
' BackupRetention : The number of backups to keep.
' Ex. 3 (the last 3 backups will be preserved):
' - If you compact daily, you would have a backup from each of the last three days.
' - If you compact weekly, you would have a backup from each of the last three weeks.
' - If you compact monthly, you would have a backup from each of the last three months.
'
'
' BackupFolder : the name of a backup folder where a temp DB will be stored
' -- If a zero length string, the DB folder will be used.
' -- If a file name, a child of the DB folder will be used.
' -- If a full path, the full path will be used.
' -- If the folder does not exist it will be created.
' -- Backups are identified by the pattern "<filename>_BAK_yymmdd".
' -- My habit is to keep a folder called "xRecycleBin" or "DB_Backups"
' in the same folder as the Access DB. Another strategy might be to keep
' a single folder for all DB backups. Backups as such may be unnecessary
' if you keep full/incremental backups using ordinary backup tools or
' utilities. However, it is still useful (and important) to compact your
' Access DBs regularly. A backup will also ensure a copy of the DB is
' saved before compacting.
' LogFilePath : a filepath to a text file for error logging.
' -- If missing log file will not be written.
'
' TestMode : In TestMode no compact actually occurs. Most of the steps involved are only imitated
' with messages and log file text. This is mainly for use while
' while coding enhancements to test the program flow.
'
' Notes:
' --------------------------------------------------------------------------------------------------------
' You can set default values for the MC_CompactDB class
' a) in Class Initialize event (implemented here)
' b) or, in Property Get procedures after creating the MC_CompactDB class
' Individual DBs (MC_DB objects) may still be given different property values that take precedence.
' --------------------------------------------------------------------------------------------------------
' The procedure will not compact a database if it is in use
' --------------------------------------------------------------------------------------------------------
' Although I almost never have issues with FSO moving/copying, these operations are verified at each step,
' in case of file or folder permission errors.
' The procedure will not compact a database if it is in use
' --------------------------------------------------------------------------------------------------------
' Almost every step of code is validated so as to be extremely careful with your database as well
' as to recover from errors without crashes so it can be run after hours or at night (with a log file
' text to record any problem).
' --------------------------------------------------------------------------------------------------------
' Another compact routine example:
' http://bytes.com/topic/access/answers/208170-how-compact-repair-back-end-front-end
' --------------------------------------------------------------------------------------------------------
Private sDefaultBackupFolder As String
Private iDefaultBackupRetention As Long
Private sDefaultLogFilePath As String
Private bDefaultAttemptToDeleteLockFile As Boolean
Private bTestMode As Boolean
Private bVerboseLogging As Boolean
Private FSO As Object '//FileSystemObject
Private col As VBA.Collection '//Holds MC_DB objects as they are added
Private re As Object '//RegExp Object
Private sTemp As String
Private Sub Class_Initialize()
'--------------------------------------
'Default defaults for MC_DB objects
sDefaultBackupFolder = "xRecycleBin"
iDefaultBackupRetention = 3
bDefaultAttemptToDeleteLockFile = False
'--------------------------------------
End Sub
Public Function MC_CompactDatabases() As Byte
Dim i As Integer
Dim sNewName As String
Dim sBackupFolder As String
Dim f As Object '//File
Dim s As String
Dim sTemp As String
Dim msg As String
Dim blnGo As Boolean
Dim d As Dictionary
Set FSO = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("Scripting.Dictionary")
Set re = CreateObject("VBScript.RegExp")
msg = ""
If col Is Nothing Then
msg = "No databases to compact (databases collection is nothing)."
ElseIf col.Count < 1 Then
msg = "No databases to compact (databases collection is empty)."
End If
If FSO Is Nothing Then
msg = "An error occurred: MC_CompactDB FileSystem Object failed to instantiate."
End If
If d Is Nothing Then
msg = "An error occurred: MC_CompactDB Dictionary Object failed to instantiate."
End If
If msg <> "" Then
MC_CompactDatabases = 2
Call MC_WriteLog(sDefaultLogFilePath, msg)
Else
For i = 1 To col.Count
'-----------------
'TRY NEXT DB
'-----------
If TypeName(col.Item(i)) = "MC_DB" Then
'//Use dictionary to check for dupe databases in DB list (we don't want to duplicate a compact/backup)
If d.Exists(col.Item(i).DBPath) Then
'//Report Duplicate Listing of a Database
If col.Item(i).LogFilePath <> "" Then
sTemp = ""
sTemp = sTemp & "Error in MyCompactDatabases file list: "
sTemp = sTemp & "" & col.Item(i).DBPath & " listed twice in compact databases file list."
Call MC_WriteLog(col.Item(i).DBPath, sTemp): Debug.Print sTemp
End If
Else
d.Add col.Item(i).DBPath, i
Call MC_RunCompact(col.Item(i)) '//Run compact on next DB
End If
End If
'----------------------------------------------------------------
Next i
End If
My_Exit:
Set FSO = Nothing
Set re = Nothing
Exit Function
Handler:
MC_CompactDatabases = 1
Resume My_Exit
End Function
Private Function MC_RunCompact(ByRef DB As MC_DB) As Byte
Dim sNewName As String
Dim f As Object '//File Object
Dim msg As String
Dim sTemp As String
Dim blnLockFileExists As Boolean
Dim ret As Byte
Dim LF As Boolean
MC_RunCompact = 1
If Me.VerboseLogging Then
sTemp = "Beginning compact routine: " & DB.DBPath
Call MC_WriteLog(DB.LogFilePath, sTemp)
End If
On Error Resume Next
Set f = FSO.GetFile(DB.DBPath)
If f Is Nothing Then
msg = "Error: unable to get file " & DB.DBPath
Call MC_WriteLog(DB.LogFilePath, msg)
Exit Function
End If
On Error GoTo ErrHandler:
'//Check for Backup Folder and create one if needed
If Not FSO.FolderExists(DB.BackupFolder) Then
Call FSO.CreateFolder(DB.BackupFolder)
End If
'//Create the backup file name
sNewName = DB.BackupFolder & "\" _
& Replace(f.Name, "." & FSO.GetExtensionName(DB.DBPath), "") _
& "_BAK_" & Format(Now, "yyyymmdd") & "." & FSO.GetExtensionName(DB.DBPath)
'//If we already have a backup today delete it
' ** MC_CompactDB will only save one backup per day, but this will allow compacts more than once a day.
' This is also useful during testing since you may run the code several times in succession.
If FSO.FileExists(sNewName) Then
If MC_DeleteFile(FSO.GetFile(sNewName)) <> 0 Then
sTemp = "Error: backup file for the current day exists and could not be deleted " & sNewName
Call MC_WriteLog(DB.LogFilePath, sTemp): Debug.Print sTemp
End If
End If
'//Attempt to delete lock file if it exists
'Note 1: This will not halt the attempt to compact and repair even if a lock file exists and cannot be deleted.
' However,
' a) we expect that if the DB is locked it cannot be compacted since it is in use.
' b) the attempt to move the file before compacting it will also fail if it is in use.
'Note 2: This function relies on a hard list of lock file extensions (see below function 'MC_LockFileExtensions')
If DB.AttemptToDeleteLockFile Then
If MC_LockFileExists(FSO.GetFile(DB.DBPath)) Then
msg = "Lock file found ... attempting to delete ... "
Call MC_DeleteLockFiles(FSO.GetFile(DB.DBPath))
If MC_LockFileExists(FSO.GetFile(DB.DBPath)) Then
msg = msg & vbNewLine & "Error: Lock file not deleted!"
Else
msg = msg & vbNewLine & "Lock file deleted!"
End If
Call MC_WriteLog(DB.LogFilePath, msg): Debug.Print msg
End If
End If
If Not Me.TestMode Then
'---------------------
'//Go Compact Database
If FSO.FolderExists(DB.BackupFolder) Then
Call Get_DBSize(DB, False)
If MC_MoveFile(DB.DBPath, sNewName) = 0 Then
'-------------------------------------------
MC_RunCompact = 5
DBEngine.CompactDatabase sNewName, DB.DBPath '//compact restores file to its original name/file location
MC_RunCompact = 0
Call Get_DBSize(DB, True)
msg = "Compact succeeded (" & DB.MB_pre & " / " & DB.MB_post & "): " & DB.DBPath
Call MC_DeleteBackups(DB)
'-------------------------------------------
Else
msg = "Error: error moving file " & DB.DBPath
End If
Else
msg = "Error: no backup folder " & DB.BackupFolder
End If
Else
'-------------
'//Go Test Run
If FSO.FolderExists(DB.BackupFolder) Then
If MC_MoveFile(DB.DBPath, sNewName) = 0 Then
Call Get_DBSize(DB, False)
Call Get_DBSize(DB, True)
msg = "TEST: Compacting ... " _
& "(" & DB.MB_pre & " / " & DB.MB_post & ") ... " _
& FSO.GetFileName(DB.DBPath)
Else
msg = "TEST: An error occurred while moving file."
End If
Else
msg = "TEST: Failed to compact " & FSO.GetFileName(DB.DBPath)
msg = msg & "(no backup folder)"
End If
Call MC_DeleteBackups(DB)
End If
My_Exit:
If Not f Is Nothing Then
Set f = Nothing
End If
If MC_RunCompact = 5 Then
'Attempt to replace the file we moved if the compact/repair fails
Call MC_CopyFile(sNewName, DB.DBPath, False)
End If
Call MC_WriteLog(DB.LogFilePath, msg): Debug.Print msg
Exit Function
ErrHandler:
msg = "An unhandled exception occurred in procedure MC_RunCompact"
Resume My_Exit:
End Function
Private Sub Get_DBSize(ByRef DB As MC_DB, _
Optional ByVal blnAfter As Boolean = False)
On Error Resume Next
If blnAfter Then
DB.MB_post = FSO.GetFile(DB.DBPath).Size
Else
DB.MB_pre = FSO.GetFile(DB.DBPath).Size
End If
End Sub
Public Sub addDB(ByVal strDB_Path As String, _
Optional ByVal strDB_BackupFolder As String, _
Optional ByVal strDB_LogFilePath As String, _
Optional ByVal varDB_BackupRetention As Variant, _
Optional ByVal blnDB_AttemptToDeleteLockFile As Variant)
'------------------------------------------------------------------------------------------------------------
'The AddDB procedure is an interface to create sister MC_DB objects
'We expect (and require) users to create MC_DB objects through this procedure rather than directly.
'This is important because this procedure adds each new MC_DB object to a collection internal
'to this class. When we run the compact procedure itself, we will then iterate the collection to
'handle each individual database to be compacted in turn. Although this results in many arguments
'in the Add method, we think that the optional arguments will usually not need to be used.
'------------------------------------------------------------------------------------------------------------
Dim newDB As MC_DB
Dim i As Long
'//the DB path is the most important and only required parameter.
Set newDB = New MC_DB
newDB.DBPath = strDB_Path
'//Set properties - follow the MC_CompactDB class defaults if not provided.
newDB.BackupFolder = IIf(strDB_BackupFolder = "", sDefaultBackupFolder, strDB_BackupFolder)
newDB.LogFilePath = IIf(strDB_LogFilePath = "", sDefaultLogFilePath, strDB_LogFilePath)
newDB.BackupRetention = IIf(IsMissing(varDB_BackupRetention), iDefaultBackupRetention, CLng(varDB_BackupRetention))
newDB.AttemptToDeleteLockFile = IIf(IsMissing(blnDB_AttemptToDeleteLockFile), bDefaultAttemptToDeleteLockFile, blnDB_AttemptToDeleteLockFile)
If col Is Nothing Then
Set col = New Collection
End If
col.Add newDB
Set newDB = Nothing
'--------------------------------------------------------------------------------------------
'Note on the MC_CompactDB class defaults for MC_DB properties:
' * Some MC_CompactDB class defaults for MC_DB's are set in the initialize event
' (this is simple to implement as a way to customize your defaults)
' * Some simply initialize to their default values (0, "", or False).
' * All can be reset right after the MC_CompactDB master class is created using Property Let
' procedures (this is familiar and easy to understand)
'--------------------------------------------------------------------------------------------
End Sub
Private Function MC_LockFileExtensions() As Variant
'//This function should be updated if future access versions use new lock file extensions
MC_LockFileExtensions = Array("ldb", "laccdb")
End Function
Private Function MC_LockFileExists(ByRef f As Object) As Boolean
Dim s(1) As String
Dim i As Long
Dim a
On Error Resume Next
'//Derive base name, without extension
s(0) = FSO.GetAbsolutePathName(f.Path)
i = Len(FSO.GetExtensionName(f.Path))
s(0) = Left(s(0), Len(s(0)) - i - 1)
a = MC_LockFileExtensions()
'//Check for lock files - .ldb/.laccdb
For i = 0 To UBound(a)
s(1) = s(0) & "." & a(i)
If FSO.FileExists(s(1)) Then
MC_LockFileExists = True
Exit Function
End If
Next i
End Function
Private Function MC_DeleteLockFiles(ByRef f As Object) As Byte
Dim s(1) As String
Dim i As Long
Dim a
On Error Resume Next
'//Derive base name, without extension
s(0) = FSO.GetAbsolutePathName(f.Path)
i = Len(FSO.GetExtensionName(f.Path))
s(0) = Left(s(0), Len(s(0)) - i - 1)
a = MC_LockFileExtensions()
'//Check for lock files and attempt to delete them
For i = 0 To UBound(a)
s(1) = s(0) & "." & a(i)
If FSO.FileExists(s(1)) Then
MC_DeleteLockFiles = MC_DeleteFile(FSO.GetFile(s(1)))
End If
Next i
End Function
Public Function EOMWeek(Optional ByVal arg As Date) As Boolean
'//This function is used when creating the list of DB's to backup, enclosing monthly backups in an IF EOMWeek() clause.
'//It is also dropped into the DeleteBackups function in another IF() to increase the date criteria for deletion -
' so that monthly backups will escape deletion.
If Month(IIf(arg, arg, Date) + 7) <> Month(IIf(arg, arg, Date)) Then
EOMWeek = True
End If
End Function
Private Function MC_CreateFolder(ByRef sFolderName As String) As Byte
On Error Resume Next
FSO.CreateFolder sFolderName
If Err Then
MC_CreateFolder = 1
End If
End Function
Private Function MC_MoveFile(ByRef sOldName As String, _
ByRef sNewName As String, Optional ByRef DB As MC_DB) As Byte
On Error Resume Next
If Me.TestMode Then
sTemp = "TEST: Moving File " & sOldName & " --> " & sNewName
If Not DB Is Nothing Then
Call MC_WriteLog(DB.LogFilePath, sTemp)
End If
Exit Function
End If
FSO.MoveFile sOldName, sNewName
If Err Then
MC_MoveFile = 1
End If
End Function
Private Function MC_DeleteFile(ByRef f As File) As Byte
On Error Resume Next
FSO.DeleteFile f.Path
If Err Then
MC_DeleteFile = 1
End If
End Function
Public Function MC_CopyFile(ByRef sSource As String, sDestination As String, bOverwrite As Boolean) As Byte
On Error Resume Next
FSO.CopyFile sSource, sDestination, bOverwrite
If Err Then
MC_CopyFile = 1
End If
End Function
Public Function MC_DeleteBackups(ByRef DB As MC_DB) As Byte
'//Backups are identified by the pattern "<filename>_BAK_yymmdd"
Dim f As File, fldr As Folder
Dim X As String
Dim a() As String
Dim msg As String
Dim s As String
Dim i As Long
Dim ret As Byte
Dim sTemp As String
With re
.Global = False
.IgnoreCase = False
.Multiline = False
s = FSO.GetBaseName(DB.DBPath)
.Pattern = s & "_BAK_\d{8}"
End With
'//Look for backup files
Set fldr = FSO.GetFolder(DB.BackupFolder)
For Each f In fldr.Files
If re.Test(f.Name) Then
ReDim Preserve a(0 To i)
X = Right(re.Execute(f.Name)(0), 8)
a(i) = X & " " & f.Name '//load array with datestamp and filename if a hit is found
i = i + 1
End If
Next f
'//i will exceed zero if at least one backup was found
If i > 0 Then
'//Sort in reverse order (descending by date of backup)
Call MC_BubbleSort_Reverse(a)
If Me.TestMode Then
For i = 0 To UBound(a)
sTemp = sTemp & "TEST: found backup file " & a(i) & IIf(i < UBound(a), vbNewLine, "")
Next i
Call MC_WriteLog(DB.LogFilePath, sTemp): Debug.Print sTemp
ElseIf Me.VerboseLogging Then '//DEBUG - listing all backups found even when running live
sTemp = "Backup files found:" & vbNewLine
For i = 0 To UBound(a)
sTemp = sTemp & " " & a(i) & IIf(i < UBound(a), vbNewLine, "")
Next i
Call MC_WriteLog(DB.LogFilePath, sTemp): Debug.Print sTemp
End If
'//Delete backups starting with oldest files until backup retention number is met.
If UBound(a) >= DB.BackupRetention Then '//note: array a is 0-based so we use ">=" rather than ">" in this line
For i = UBound(a) To DB.BackupRetention Step -1
If Me.TestMode Then
Call MC_WriteLog(DB.LogFilePath, "TEST: Deleting File ... " & a(i))
Else
ret = MC_DeleteFile(FSO.GetFile(DB.BackupFolder & "\" & (Right(a(i), Len(a(i)) - 9))))
If ret <> 0 Then
Call MC_WriteLog(DB.LogFilePath, "Error Deleting backup copy: " & a(i))
Else
If Me.VerboseLogging Then
Call MC_WriteLog(DB.LogFilePath, "Deleting File ... " & a(i))
End If
End If
End If
Next i
End If
End If
End Function
Private Sub MC_BubbleSort_Reverse(ByRef a() As String)
Dim Temp As String
Dim i As Integer
Dim NoExchanges As Boolean
Do
NoExchanges = True
For i = LBound(a) To UBound(a) - 1
If a(i) < a(i + 1) Then
NoExchanges = False
Temp = a(i)
a(i) = a(i + 1)
a(i + 1) = Temp
End If
Next i
Loop While Not NoExchanges
End Sub
Public Sub MC_WriteLog(ByRef sLogPath As String, ByRef s As String)
Dim ts As Object
Dim f As File
On Error Resume Next
With FSO
If .FileExists(sLogPath) Then
Set f = .GetFile(sLogPath)
If f.Size() > 8000000 Then
Set f = Nothing
Set FSO = Nothing
Exit Sub '//Runaway error log
End If
End If
Set f = Nothing
Set ts = .OpenTextFile(sLogPath, 8, True, 0) '//8 - for appending; 0 - TristateFalse (Ansii)
ts.WriteLine s
End With
If Not ts Is Nothing Then
ts.Close
Set ts = Nothing
End If
End Sub
'-----------------------------------------------------------------------
'Exposed Properties
' * Some default values are set in Class_Initialize
' * Backup retention must be set since zero is meaningful -
' hence if we initialize to 0 that means no backups saved.
' accordingly we use Class_Initialize to set preferred initial defaults for the MC_CompactDB class.
'
Public Property Let DefaultBackupFolder(ByVal arg As String)
sDefaultBackupFolder = arg
End Property
Public Property Get DefaultBackupFolder() As String
DefaultBackupFolder = sDefaultBackupFolder
End Property
Public Property Let DefaultBackupRetention(ByVal arg As Long)
iDefaultBackupRetention = arg
End Property
Public Property Get DefaultBackupRetention() As Long
DefaultBackupRetention = iDefaultBackupRetention
End Property
Public Property Let DefaultAttemptToDeleteLockFile(ByVal arg As Boolean)
bDefaultAttemptToDeleteLockFile = arg
End Property
Public Property Get DefaultAttemptToDeleteLockFile() As Boolean
DefaultAttemptToDeleteLockFile = bDefaultAttemptToDeleteLockFile
End Property
Public Property Get DefaultLogFilePath() As String
DefaultLogFilePath = sDefaultLogFilePath '//This value must be set explicitly by the user.
End Property
Public Property Let DefaultLogFilePath(ByVal arg As String)
sDefaultLogFilePath = arg
End Property
Public Property Get TestMode() As Boolean
TestMode = bTestMode
End Property
Public Property Let TestMode(ByVal arg As Boolean)
bTestMode = arg
End Property
Public Property Let VerboseLogging(ByVal arg As Boolean)
bVerboseLogging = arg
End Property
Public Property Get VerboseLogging() As Boolean
VerboseLogging = bVerboseLogging
End Property