窗体加一个Command控件,点击控件即可完成,把下列代码全部复制到窗体上。
Dim s As String
Private Sub Command1_Click()
On Error Resume Next
Dim sNewName As String
Dim sBakFile As String
Dim sDataBase As String
sNewName = s '提取数据库
sDataBase = sNewName
MousePointer = 11
snewfile = Left$(sDataBase, Len(sDataBase) - 3) & "NEW"
sBakFile = Left$(sDataBase, Len(sDataBase) - 3) & "BAK"
FileCopy sDataBase, sBakFile '备份数据库,重新命名
DBEngine.RepairDatabase sDataBase '修复数据库
If Dir(snewfile) <> "" Then
Kill snewfile '如果目标数据库存在,则删除目标数据库
End If
DBEngine.CompactDatabase sDataBase, snewfile '压缩数据库
If Dir(sBakFile) <> "" Then '删除备份数据库
Kill sBakFile
End If
If Dir(sDataBase) <> "" Then
Kill sDataBase ' 删除数据库
End If
FileCopy snewfile, sDataBase '重新复制数据给数据库
MousePointer = 0
MsgBox "压缩数据库完成"
Unload Me
Set mClass显菜单 = New Class显菜单
Set mClass显菜单 = Nothing
End Sub
Private Sub Form_Load()
s = App.Path & "/db1.mdb"
End Sub