Ex8: VBA - Distinct users Connected to DB using ADO

Count the number of distinct users connected to the database using ADO in VBA

Function UserCount() As Long
    Dim cnLocal As ADODB.Connection             'Current project connection.
    Dim cnBackEnd As New ADODB.Connection       'Connection to back end database.
    Dim rsBEUserRoster As New ADODB.Recordset   'JET User Roster for back end database.
    Dim rsTarget As New ADODB.Recordset         'Temp table to record users and de-dupe.
    Dim strPath As String                       'Full path to back end.
    Dim strSql As String                        'SQL string.
    Dim lngKt As Long                           'Loop controller.
    Dim dtEnteredOn As Date                     'Current date and time.
    
    'Set this to the full path of your back end database.
    strPath = "C:\Data\Northwind2003.mdb"
    
    'Open the JET User Roster for the back end.
    cnBackEnd.Provider = "Microsoft.Jet.OLEDB.4.0"
    cnBackEnd.Open "Data Source=" & strPath
    Set rsBEUserRoster = cnBackEnd.OpenSchema(adSchemaProviderSpecific, , _
        "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
    
    'Clear temp table, and copy the user roster in.
    dtEnteredOn = Now()
    Set cnLocal = CurrentProject.Connection
    cnLocal.Execute "DELETE FROM tzJetUserRoster;"
    rsTarget.Open "tzJetUserRoster", cnLocal, adOpenDynamic, adLockOptimistic
    Do While Not rsBEUserRoster.EOF
        rsTarget.AddNew
            For lngKt = 0 To 3
                rsTarget(lngKt) = rsBEUserRoster(lngKt)
                rsTarget!EnteredOn = dtEnteredOn
            Next
        rsTarget.Update
        rsBEUserRoster.MoveNext
    Loop
    rsTarget.Close
    rsBEUserRoster.Close
    cnBackEnd.Close
    
    'Get the count of the number of distinct users who are connected.
    strSql = "SELECT DISTINCT Computer_Name FROM tzJetUserRoster WHERE Connected = True;"
    Set rsTarget = New ADODB.Recordset
    rsTarget.Open strSql, cnLocal, adOpenKeyset
    If Not (rsTarget.BOF And rsTarget.EOF) Then
        rsTarget.MoveLast
        UserCount = rsTarget.RecordCount
    End If
    rsTarget.Close
    
    'Dereference objects
    Set rsTarget = Nothing
    Set rsBEUserRoster = Nothing
    Set cnLocal = Nothing
    Set cnBackEnd = Nothing
End Function