I believe that this procedure has compacted various "backends" for me
for many years and seems to work in the present when more than one
user is linked to the backend, provided that those uers are idle.
Option Base 0
Option Explicit
Private Const AttachedTable& = 6
Private Const FileNotFoundErrNumber& = 53
Private Const Notify As Boolean = False
Public Sub CompactAttachedTableMDBS()
will fail if no reference to DAO
On Error GoTo CompactAttachedTableMDBSErr
Dim rcs As DAO.recordset
Dim SQL$
If Forms.Count Or Reports.Count Then
MsgBox "Please, close all forms and reports, and retry.",
vbExclamation, "FFDBA"
Else
SQL = "SELECT Distinct CStr(DataBase) AS db" _
& " FROM MSysObjects WHERE Type=" & AttachedTable
With DBEngine(0)(0)
.TableDefs.Refresh
Set rcs = .OpenRecordset(SQL)
With rcs
Do While Not .EOF
If DoesFileExist1997(!db) Then
If CanBeOpenedExclusively(!db) Then
Shell SysCmd(acSysCmdAccessDir) &
"MsAccess.Exe " & """" & !db & """" & " /compact"
If Notify Then
MsgBox "Successfully Compacted" _
& vbCrLf _
& !db & "." _
, vbInformation, "FFDBA"
End If
Else
MsgBox "Can't compact" _
& vbCrLf _
& !db & "." _
& vbCrLf _
& "Database seems to be opened exclusively
by another user.", vbExclamation, "FFDBA"
End If
Else
MsgBox "Can't compact" _
& vbCrLf _
& !db & "." _
& vbCrLf _
& "Database seems to have been moved or
deleted.", vbExclamation, "FFDBA"
End If
.MoveNext
Loop
.Close
End With
End With
End If
CompactAttachedTableMDBSExit:
Set rcs = Nothing
Exit Sub
CompactAttachedTableMDBSErr:
With Err
MsgBox .Description, vbCritical, "Error: " & .Number
End With
Resume CompactAttachedTableMDBSExit
End Sub
Private Function CanBeOpenedExclusively(ByVal FullPath$) As Boolean
Dim d As Database
Dim p As PrivDBEngine
Set p = New PrivDBEngine
On Error Resume Next
Set d = p(0).OpenDatabase(FullPath, True)
CanBeOpenedExclusively = Not (d Is Nothing)
p(0).Close
Set d = Nothing
Set p = Nothing
End Function
Public Function DoesFileExist1997(ByVal FilePath$) As Boolean
On Error GoTo DoesFileExist1997Err
GetAttr FilePath
DoesFileExist1997 = True
DoesFileExist1997Exit:
Exit Function
DoesFileExist1997Err:
With Err
If .Number <FileNotFoundErrNumber Then
MsgBox .Description, vbCritical, "Error Number: "
& .Number
End If
End With
Resume DoesFileExist1997Exit
End Function
On Aug 27, 1:41*am, "Chris O'C via AccessMonster.com" <u29189@uwe>
wrote:
Compacting the db requires exclusive access to the file. *If anyone else is
connected to the back end at the same time you want to compact it, the back
end can't be compacted.
