CompactDB&Space

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
 
 
 
 Si richiede che il Database da compattare sia nella stessa
directory di questa applicazione

Assicurarsi di possedere queste References
MS DAO 3.X Object Library
MS Scripting Runtime

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

Si richiede che il Database da compattare sia nella stessa
directory di questa applicazione

Assicurarsi di possedere queste References
MS DAO 3.X Object Library
MS Scripting Runtime