Private Sub cmdBackup_Click()
Screen.MousePointer = vbHourglass
On Error GoTo errhandler
'close all DAO's to release resources
Dim ws As Workspace
Dim db As Database
Dim rs As Recordset
For Each ws In Workspaces
For Each db In ws.Databases
For Each rs In db.Recordsets
rs.Close
Set rs = Nothing
Next
db.Close
Set db = Nothing
Next
ws.Close
Set ws = Nothing
Next
'if a compacted version already exists kill it
If Dir$(App.Path & "\Compacted.mdb") <> "" Then
Kill (App.Path & "\Compacted.mdb")
End If
'compact the db (must first have been opened using OpenDatabase)
DBEngine.CompactDatabase App.Path & "\MyDB.mdb", App.Path & "\Compacted.mdb"
If FileLen(App.Path & "\Compacted.mdb") > 0 Then
response = MsgBox("size in bytes" & vbCrLf & "before after" & vbCrLf & FileLen(App.Path & "\MyDB.mdb") & " " & FileLen(App.Path & "\compacted.mdb"), vbOKOnly, "Compaction results")
Kill App.Path & "\MyDB.mdb"
FileCopy App.Path & "\Compacted.mdb", App.Path & "\MyDB.mdb"
Else
MsgBox ("Database did not compact properly, original left untouched")
End If
GoTo done
errhandler:
MsgBox (Err.Number & " " & Err.Description)
done:
Screen.MousePointer = vbDefault
End Sub