• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• Compact & Repair Database Enhanced

Compact & Repair Database Enhanced

Easily Compact & Repair a MS Access Database and display the size differences.

Inputs
strDatabase as string

Assumes
This code assumes that your Access database is in the same directory as your exe. Be sure to reference: MS DAO 3.X Object Library MS Scripting Runtime

Returns
Boolean (True if Successful)

Rate Compact & Repair Database Enhanced

• 1
• 2
• 3
• 4
• 5

(3(3 Vote))

Public Function CompactDatabase(strDatabaseName As String) As Boolean
On Error GoTo Err_CompactDatabase
Dim strPath As String
Dim strPath1 As String
Dim strPathSize As String
Dim strPathSize2 As String
Screen.MousePointer = vbHourglass
'Save Paths for Database
strPath = App.Path & "\" & strDatabaseName
strPath1 = App.Path & "\" & "BackupOf" & strDatabaseName
'Repair Database
DBEngine.RepairDatabase strPath
'Get Size of File Before Compacting
strPathSize = GetFileSize(strPath)
'Kill the file if it exists
If Dir(strPath1) <> "" Then Kill strPath1
'Compact Database to New Name
DBEngine.CompactDatabase strPath, strPath1
''Kill the file if it exists
If Dir(strPath) <> "" Then Kill strPath
'Compact back to original Name
DBEngine.CompactDatabase strPath1, strPath
'Kill the file, no need to save it
If Dir(strPath1) <> "" Then Kill strPath1
'Get Size of File After Compacting
strPathSize2 = GetFileSize(strPath)
CompactDatabase = True
'Display the Summary
MsgBox UCase(strDatabaseName) & " compacted successfully." _
 & vbNewLine & vbNewLine & "Size before compacting:" & vbTab & strPathSize _
 & vbNewLine & "Size after compacting:" & vbTab & strPathSize2, vbInformation, "Compact Successful"
Err_CompactDatabase:
 Select Case Err
 Case 0
 Case Else
 MsgBox Err & ": " & Error, vbCritical, "CompactDatabase Error"
 End Select
 
Screen.MousePointer = vbNormal
End Function
Public Function GetFileSize(strFile As String) As String
Dim fso As New Scripting.FileSystemObject
Dim f As File
Dim lngBytes As Long
Const KB As Long = 1024
Const MB As Long = 1024 * KB
Const GB As Long = 1024 * MB
Set f = fso.GetFile(fso.GetFile(strFile))
lngBytes = f.Size
If lngBytes < KB Then
 GetFileSize = Format(lngBytes) & " bytes"
ElseIf lngBytes < MB Then
 GetFileSize = Format(lngBytes / KB, "0.00") & " KB"
ElseIf lngBytes < GB Then
 GetFileSize = Format(lngBytes / MB, "0.00") & " MB"
Else
 GetFileSize = Format(lngBytes / GB, "0.00") & " GB"
End If
End Function