I'm sure I'm just being blind here. I need to compact my BE data file, but the code fails because the initial file copy to backup the data file gives a permission denied. (The file is still in use). How does the front end release it's hold?
I've seen several examples of compacting the MS Access Backend, but they all predicate their code with the statament 'Make sure all connections to the BE are disconnected".
In my case both files are local. There are no other users. All forms in the FE have been closed.
The user is not a DBadmin type so a single button on the front end app to compact both would be ideal. Here is the compact code...
At error postion 20 the file copy fails...
How do I release the FE's hold on the Backend? What is odd is I can manually copy the file while the FE is attached by using Explorer so I can understand why I can't copy the file in VBA.
I've seen several examples of compacting the MS Access Backend, but they all predicate their code with the statament 'Make sure all connections to the BE are disconnected".
In my case both files are local. There are no other users. All forms in the FE have been closed.
The user is not a DBadmin type so a single button on the front end app to compact both would be ideal. Here is the compact code...
Code:
Public Function BE_Compact(Cnnt_str As String, frm_nm As String) As Boolean
On Error GoTo Err_BE_Compact
Dim Fl_BE_Cnt_Str As String, BE_DB_Name_Str As String, s_Pos As Integer, BE_Path_Str As String, BE_Full_Nm_Str As String
Dim Tmp_BE_Hold_FNM_Str As String, BkUp_FNMN_Str As String, Err_Pos As Integer, T_Def As TableDef
Dim New_Db As Database, e_Cnt As Integer
Dim ErrAns As Integer, ErrMsg As String
Err_Pos = 1
'close calling form
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
End Function
How do I release the FE's hold on the Backend? What is odd is I can manually copy the file while the FE is attached by using Explorer so I can understand why I can't copy the file in VBA.