如何修复和access压缩数据库

Question

同题

Answer 1

'引用MICROSOFT JET AND REPLICATION OBJECTS 2.6'JRO具有修复数据库的功能.下在的程序让你参考一下:
'
'恢复和备份MDB数据库
'函数名:BakResumeMdb
'参数:P_Cnn ADODB连接,SourFileName 源文件名,ObjFileName 目标文件名,
'     Provider Provider参数(视JET版而定,默认是4.0),UserID 用户名,
'     UserPwd 密码,WorkType 操作类型(0 备份,1 恢复)
'返回值:TRUE 成功,FALSE 失败.
'注:当WorkType=0时,源文件名是要备份文件,目标文件名是备份文件.
'   当WorkType=1时,源文件名是备份文件,目标文件名要恢复的文件.
Public Function BakResumeMDB(P_Cnn As ADODB.Connection, _
                       SourFileName As String, _
                       ObjFileName As String, _
                       Optional Provider As String = "Microsoft.Jet.OLEDB.4.0", _
                       Optional UserID As String = "admin", _
                       Optional UserPwd As String = "", _
                       Optional WorkType As Long = 0) As Boolean
    
    Dim Yjro As New JRO.JetEngine
    Dim WorkPath As String
    Dim FileCon As New SmFileCls
    
    On Error Resume Next
    '/关闭连接
    P_Cnn.Close: Set P_Cnn = Nothing
    DoEvents
    '/-------------------------------
    '/压缩
    Yjro.CompactDatabase "Provider=" & Provider & SourFileName & ";" & _
                         "Jet OLEDB:Database Password=" & UserPwd & ";" & _
                         "User ID=" & UserID & ";", _
                         "Provider=" & Provider & ";Data Source=" & ObjFileName & ";" & _
                         "Jet OLEDB:Database Password=" & UserPwd & ";" & _
                         "User ID=" & UserID & ";"
    DoEvents
    '/删除旧文件，将压缩后的文件ＣＯＰＹ到旧位置
    If Not (FileCon.FileCheck(SourFileName) And FileCon.FileCheck(ObjFileName)) Then
       If WorkType = 0 Then
          '/备份。
          Call CreateMdbConn(P_Cnn, SourFileName, , UserID, UserPwd)
       Else
          '/恢复
          Call CreateMdbConn(P_Cnn, ObjFileName, , UserID, UserPwd)
       End If
       Err.Number = -1
    End If
    Set FileCon = Nothing
    Set Yjro = Nothing: Err.Clear
    BakResumeMDB = (Err.Number = 0)
End Function

Answer 2

'压缩和修复数据库
Public Function CompDatabase() As Boolean
    On Error GoTo ErrMsg
    Dim JRO As New JRO.JetEngine
    Dim tempDBPath As String
    Dim conStr1 As String, conStr2 As String
    Dim i As Integer
    
    If MsgBox("你确定要压缩当前数据库吗？", vbQuestion + vbOKCancel + vbDefaultButton2, "小心！") = vbCancel Then
       Exit Function
    End If
    
    Screen.MousePointer = 11
    
    For i = Len(MdbSourcePath) To 1 Step -1
        If Mid(MdbSourcePath, i, 1) = "\" Then
            tempDBPath = Left(MdbSourcePath, i) & "tempDocument.mdb"
            Exit For
        End If
    Next i
    
    If Dir(tempDBPath) <> "" Then
        Kill tempDBPath
    End If
    
    conStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MdbSourcePath & ";jet oledb:database password=790319"
    conStr2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & tempDBPath & ";jet oledb:database password=790319"
    
    con.Close '先关闭全局连接
    JRO.CompactDatabase conStr1, conStr2
    
    Kill MdbSourcePath
    Name tempDBPath As MdbSourcePath
    
    ConnectDatabase con '再开启全局连接
    
    Screen.MousePointer = 0
    
    MsgBox "数据库压缩成功", vbInformation + vbOKOnly, "祝贺"
    CompDatabase = True
    Exit Function
ErrMsg:
    Screen.MousePointer = 0
    CompDatabase = False
    MsgBox "请确保其它应用程序没有使用当前数据库！" & vbCrLf & Err.Description & "然后关闭其它所有子窗体后再恢复！", vbInformation + vbOKOnly, "提示"
    CheckConnection con
End Function