私はここで盲目であると確信しています。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