Tuesday, 8 October 2013

VBA Modules: Access: accCompactRepair v2.03

Read this for full information on these modules

This nifty little module performs a compact & repair on an Access database, or for all Access databases under a specified path. 

accSweepForDatabases runs acCompactRepair on all *.accdb and *.mdb files within [and beneath] the specified folder. (NB: you'll need to comment out the line for .accdb if you only have Access 2003 installed because it won't open those files.)

Syntax to auto-compact all databases under a path:

Access 2007/2010:
accSweepForDatabases "C:\Folder\", True, False, False

Access 2003:

accSweepForDatabases "C:\Folder\", True, False, True


acCompactRepair launches Access, opens the database, sets the "Compact on Close" option to "True", then quits.

Syntax to auto-compact:
acCompactRepair "C:\Folder\Database.accdb", True

I tend to use it after running a Delete query or removing a single table object from a database.

Syntax to return to default* afterwards:
acCompactRepair "C:\Folder\Database.accdb", False

*not necessary, but if your back end database is >1GB this can be rather annoying when you go into it directly and it then takes >2 minutes to quit.

'accCompactRepair
'v2.03 2013-11-28 17:43

'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   TJP@tomparish.me.uk
'   http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'includes code from
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for improved error handling

'   v2.03   added option for Access 2003 users
'           improved code annotation
'   v2.02   bugfix preventing Compact when bAutoCompact set to False
'           bugfix with "OLE waiting for another application" msgbox
'           added "MB" to start & end sizes of message box at end
'   v2.01   added size reduction to message box
'   v2.00   added recurse
'   v1.00   original version

Option Explicit

Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _
    , Optional bAutoCompact As Boolean = False, Optional bOnlyAccess2003 As Boolean) As String
'v2.03 2013-11-28 17:43
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True

'syntax:
'   accSweepForDatabases "path", [False], [True]

'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":
'   accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]

Application.DisplayAlerts = False

Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single
Dim SizeBefore As Long, SizeAfter As Long
t = Timer

'scan path for any .mdb and .accdb files
    If bOnlyAccess2003 = False Then RecursiveDir colFiles, strFolder, "*.accdb", True
    RecursiveDir colFiles, strFolder, "*.mdb", True

'now compact & repair the list of databases
    For Each vFile In colFiles
        'Debug.Print vFile
        SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)
On Error GoTo CompactFailed
    If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"
        acCompactRepair vFile, bAutoCompact
        i = i + 1  'counts successes
        GoTo NextCompact
CompactFailed:
On Error GoTo 0
        j = j + 1   'counts failures
        sFails = sFails & vFile & vbLf  'records failure
NextCompact:
On Error GoTo 0
        SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)

    Next vFile

Application.DisplayAlerts = True

'display message box, mark end of process
    accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"
    If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails
    MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"

End Function

Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean
'v2.02 2013-11-28 16:22
'if doEnable = True will compact and repair pthfn
'if doEnable = False will then disable auto compact on pthfn

On Error GoTo CompactFailed

Dim A As Object
Set A = CreateObject("Access.Application")
With A
    .OpenCurrentDatabase pthfn
    .SetOption "Auto compact", True
    .CloseCurrentDatabase
    If doEnable = False Then
        .OpenCurrentDatabase pthfn
        .SetOption "Auto compact", doEnable
    End If
    .Quit
End With
Set A = Nothing
acCompactRepair = True
Exit Function
CompactFailed:
End Function


'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for error handling

Private Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
On Error Resume Next
    strTemp = ""
    strTemp = Dir(strFolder & strFileSpec)
On Error GoTo 0
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
On Error Resume Next
        strTemp = ""
        strTemp = Dir(strFolder, vbDirectory)
On Error GoTo 0
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

No comments:

Post a comment