数据库压缩

窗体加一个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