Private Sub 开始压缩_Click()
Dim StrFTemp As String
Dim StrFName As String
Dim Lstar As Long, Lend As Long
''''''''''''''''''''''''
Dim rst As ADODB.Recordset
Dim StrSql As String
Set rst = New ADODB.Recordset
StrSql = "select database from MSysObjects group by database HAVING (((database)<>''))"
rst.Open StrSql, CurrentProject.Connection, adOpenStatic
If rst.RecordCount > 0 Then
Do While Not rst.EOF
StrFName = rst("database")
StrFTemp = "d:\temp001.mdb" '可在此处稍加修改，保存临时文件与源文件名相对应
If Dir(StrFTemp) <> "" Then Kill StrFTemp
If Dir(StrFName) <> "" Then Name StrFName As StrFTemp Else MsgBox StrFName & "不存在，无法进行压缩！"
DBEngine.CompactDatabase StrFTemp, StrFName
Kill Strftemp '如果为了防止压缩失败，可保留对应的临时文件
MsgBox "已经成功压缩" & StrFName
rst.MoveNext
Loop
End If
''''''''''''''''''''''''
End Sub
Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。
Dim dbs As Database, rst As DAO.Recordset
Set dbs = CurrentDb()
' 打开链接表查看表链接信息是否正确。
On Error Resume Next
Set rst = dbs.OpenRecordset("BaseData")
rst.Close
' 如果没有错误，返回 True 。
If Err = 0 Then
CheckLinks = True
Else
CheckLinks = False
End If
End Function
Private Sub Form_load()
If CheckLinks = False Then
MsgBox "本地后台数据库错误,需要重新设定数据源", vbInformation + vbOKOnly, "系统:严重错误"
On Error GoTo link_Err
'删除原有连接表
Dim rst As ADODB.Recordset
Dim StrSql As String
Set rst = New ADODB.Recordset
StrSql = "select * from MSysObjects where database<>''"
rst.Open StrSql, CurrentProject.Connection, adOpenStatic
If rst.RecordCount > 0 Then
Do While Not rst.EOF
DoCmd.DeleteObject acTable, rst("name")
rst.MoveNext
Loop
Else
Resume ReferLink
End If
'删除原有连接表'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''End
ReferLink:
DoCmd.RunCommand acCmdLinkTables ' 打开链接表管理器