0

私はここで盲目であると確信しています。BE データ ファイルを圧縮する必要がありますが、データ ファイルをバックアップするための最初のファイル コピーでアクセス許可が拒否されるため、コードは失敗します。MS Access バックエンドを圧縮する例をいくつか見てきましたが、それらはすべてコードの前に「すべての接続が切断されていることを確認してください」という文を付けています。
私の場合、両方のファイルがローカルです。他のユーザーはいません。すべてのフォームが閉じられています。 .
ユーザーは DBadmin タイプではないため、両方を圧縮するためのフロント エンド アプリの 1 つのボタンが理想的です. 圧縮コードは次のとおりです...

Err_Pos = 1
    If IsFormLoaded(frm_nm) Then
        DoCmd.Close acForm, frm_nm
    End If


    Fl_BE_Cnt_Str = Cnnt_str
    BE_Full_Nm_Str = Split(Split(Fl_BE_Cnt_Str, "Database=")(1), ";")(0)
    s_Pos = InStrRev(Fl_BE_Cnt_Str, "\")
    BE_DB_Name_Str = Right(Fl_BE_Cnt_Str, Len(Fl_BE_Cnt_Str) - s_Pos)
    s_Pos = InStrRev(BE_Full_Nm_Str, "\")
    BE_Path_Str = Left(BE_Full_Nm_Str, s_Pos)
    Tmp_BE_Hold_FNM_Str = BE_Path_Str & "Tmp_BE.accdb"

Err_Pos = 5

   're-map current table links to empty DB with same table Structure
    For Each T_Def In CurrentDb.TableDefs
        If InStr(T_Def.Name, "MSys") = 0 Then
            T_Def.Connect = ";Database=" & BE_Path_Str & "MPD_BEStruct.accdb"
            T_Def.RefreshLink
        End If


    Next T_Def

 Err_Pos = 10
    'Backup
    s_Pos = InStrRev(BE_DB_Name_Str, ".")
    BkUp_FNMN_Str = Left(BE_DB_Name_Str, s_Pos) & ".BAK"
Err_Pos = 15
    ' remove  possible left over backup
    Kill BE_Path_Str & BkUp_FNMN_Str
    On Error GoTo Err_BE_Compact
Err_Pos = 20

    FileCopy BE_Full_Nm_Str, BE_Path_Str & BkUp_FNMN_Str
    'Compact
    DBEngine.CompactDatabase BE_Full_Nm_Str, Tmp_BE_Hold_FNM_Str
 Err_Pos = 25
    'Delete Uncompacted Version
    Kill BE_Full_Nm_Str
 Err_Pos = 30

    'Rename Compacted Version
    Name Tmp_BE_Hold_FNM_Str As BE_Full_Nm_Str

 Err_Pos = 35
    'reconnect to the new compacted Back End
     For Each T_Def In CurrentDb.TableDefs
        If InStr(T_Def.Name, "MSys") = 0 Then
            T_Def.Connect = ";Database=" & BE_Path_Str & BE_DB_Name_Str
            T_Def.RefreshLink
        End If
     Next T_Def

    ' let backup stay around if compact has corrupted DB
    'Kill BE_Path_Str & "MPD_BEStruct.accdb"

 Err_Pos = 40

    SendKeys "%(FMC)"


'

Exit_BE_Compact:
    Exit Function

Err_BE_Compact:
e_Cnt = e_Cnt + 1
If e_Cnt < 1000 Then
    Select Case Err.Number
        Case 3204
            If Err_Pos = 5 Then
                Kill BE_Path_Str & "MPD_BEStruct.accdb"
            End If
            Resume
        Case Else
            Dim Why_Str As String
            Select Case Err_Pos
                Case 5
                    Why_Str = "record Source Disconnect Error"
                Case 10
                    Why_Str = "record Source Disconnect Error"
                Case 15
                    Why_Str = "Previous Backup won't delete"
                Case 20
                    Why_Str = "Tmp Back up of BackEnd datafile failed"
                Case 25
                    Why_Str = "Compac of BackEnd failed"
                Case 30
                    Why_Str = "Rename of compacted BackEnd failed"
                Case 35
                    Why_Str = "Reconnect to BackEnd failed"
            End Select
            If ErrChoice = vbYesNoCancel Then
                ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & Why_Str & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                    "'No' to Exit Procedure." & vbCrLf & "or 'Cancel' to break into code"
            Else
                ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & Why_Str & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                    "'No' to Exit Procedure."
            End If
   End Select
Else
    Why_Str = "Too Many Errors"
    ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & Why_Str & vbNewLine & _
        "Press 'OK' to Exit Procedure."
    ErrAns = MsgBox(ErrMsg, _
        vbCritical + vbQuestion + vbOKOnly, "Function: BE_Compact")
    Resume Exit_BE_Compact

 End If

 ErrAns = MsgBox(ErrMsg, _
    vbCritical + vbQuestion + ErrChoice, "Function: BE_Compact")
If ErrAns = vbYes Then
    Resume Next
ElseIf ErrAns = vbCancel Then
    On Error GoTo 0
    Resume
Else
    Resume Exit_BE_Compact
End If
4

1 に答える 1