[AccessD] Compact BE on Close - An Example

Hello to All!

I've believed for a while that setting Compact On Close for the FE would
also compact the BE.  But a little testing disproved that.  For the BE to
auto-compact, it must actually be opened by the Access application and then
closed.

With some help from Stephen Bond, I was able to put together this code to
compact the BE
when the FE is closed by the last person.

Two things about the BE: First - you must set its Compact On Close option to
true.  Second - avoid User Security on the BE or your users will be asked to
enter their user name and password as they are shutting down their FE.

You should be controlling the FE so that pushing an Exit or Quit button is
the only way the FE can be closed.  (Discussed in previous posts.)  When you
push that button, call the CompactBE procedure immediately before using the
DoCmd.Quit method.

I've used this successfully at one customer site.  I hope this will work for
everyone - if you see any problems with this then speak up!

Thanks!
Dan Waters
ProMation Systems, Inc.

PS - I'm going to try to see if this is publishable information.



'-- Paste the following into a Standard Module titled 'Compact BE' 

Option Compare Database
Option Explicit

Public Sub CompactBE()
On Error GoTo EH

    Dim stgPath As String
    Dim blnExclusive As Boolean
    Dim appAccess As Access.Application
    Dim varReturn As Variant
    
    If CountCurrentUsers > 1 Then
        Exit Sub
    End If
    
    stgPath = "\\ServerPath\SystemFolder\BackEnd\BE.mdb"
    '-- Keep users out while the BE is compacting
    blnExclusive = True
    
    Set appAccess = New Access.Application
    
    varReturn = SysCmd(acSysCmdSetStatus, "Compacting BE")
    
    appAccess.OpenCurrentDatabase stgPath, blnExclusive
    '-- When the BE closes it will auto-compact.  And it happens quickly!
    appAccess.CloseCurrentDatabase
    appAccess.Quit
    
    varReturn = SysCmd(acSysCmdClearStatus)
    
    Exit Sub
    
EH:
    Application.Echo True
    Call GlobalErrors("", Err.Number, Err.Description, "Compact BE",
"CompactBE")

End Sub

Public Function CountCurrentUsers() As Integer
On Error GoTo EH

    Dim con As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim stgAccessVersion As String
    Dim intUserCount As Integer
    Dim stgUserName As String
    
    stgAccessVersion = SysCmd(acSysCmdAccessVer)

    '-- The user roster is exposed as a provider-specific schema rowset _
        in the Jet 4.0 OLE DB provider.  You have to use a GUID to _
        reference the schema, as provider-specific schemas are not _
        listed in ADO's type library for schema rowsets

    Select Case stgAccessVersion
        Case "9.0"
            '-- This is from MSKB 198755 and is specific to Access 2000
            con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=\\ServerPath\SystemFolder\FrontEnd\FE.mdb"
        Case "10.0"
            '-- This is from MSKB 285822 and is specific to Access 2002 or
2003
            Set con = CurrentProject.Connection
        Case "11.0"
            '-- This is from MSKB 285822 and is specific to Access 2002 or
2003
            Set con = CurrentProject.Connection
    End Select

    Set rst = con.OpenSchema(adSchemaProviderSpecific, ,
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")
    
    If rst.EOF = False Then
        Do While rst.EOF = False
            stgUserName = Left$(rst.Fields(1), InStr(1, rst.Fields(1),
Chr(0)) - 1)
            If stgUserName <> "Admin" Then
                intUserCount = intUserCount + 1
            End If
            rst.MoveNext
        Loop
        CountCurrentUsers = intUserCount
    Else
        CountCurrentUsers = 0
    End If
    
    rst.Close
    Set rst = Nothing

    Exit Function
    
EH:
    Application.Echo True
    Call GlobalErrors("", Err.Number, Err.Description, "Count Current
Users", "CountCurrentUsers")
    
End Function