Option Compare Database
Option Explicit

' From Access 2000 Developer's Handbook, Volume II
' by Litwin, Getz, and Gilbert. (Sybex)
' Copyright  1999 . All rights reserved.
 
' The user list schema information requires this magic
' number. Why isn't a constant predefined for this?
' Who knows.
Const adhcUsers =  "{947bb102-5d43-11d1-bdbf-00c04fb92675}" 

Const adhcAllowUsers =  "Allow New Users" 
Const adhcDisallowUsers =  "Disallow New Users" 

Sub BuildUserList()

    ' Builds a list of users in the database
    ' using the OpenSchema method on the
    ' Connection object.

    ' From Access  2000  Developer's Handbook, Volume II
    ' by Litwin, Getz, and Gilbert. (Sybex)
    ' Copyright 1999. All rights reserved.
 
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim intUser As Integer
    Dim strUser As String
    Dim varVal As Variant
    
    ' Headings
    strUser =  "Computer;UserName;Connected?;Suspect?" 
    
    Set cnn = CurrentProject.Connection
    
    Set rst = cnn.OpenSchema( _
     Schema:=adSchemaProviderSpecific, _
     SchemaId:=adhcUsers)
    
    With rst
        Do Until .EOF
            intUser = intUser +  1 
            For Each fld In .Fields
                varVal = fld.Value
                ' Some of the returned values are
                ' null-terminated strings so you need
                ' to lop off the null characters
                If InStr(varVal, vbNullChar) > 0 Then
                    varVal = Left(varVal, _
                     InStr(varVal, vbNullChar) - 1)
                End If
                strUser = strUser & ";" & varVal
            Next
            .MoveNext
        Loop
    End With
    txtUsers = intUser
    lboUsers.RowSource = strUser
    
    ' Cleanup
    rst.Close
    Set rst = Nothing
    Set fld = Nothing
    Set cnn = Nothing
End Sub

Private Sub cmdClose_Click()
    DoCmd.Close acForm, Me.Name
End Sub

Private Sub cmdRefreshNow_Click()
    Call BuildUserList
End Sub

Private Sub cmdShutdown_Click()
    If cmdShutdown.Caption = adhcDisallowUsers Then
        ' Initiate connection control and fixup
        ' button caption
        CurrentProject.Connection. _
         Properties( "Jet OLEDB:Connection Control" ) =  1 
        cmdShutdown.Caption = adhcAllowUsers
    Else
        ' Undo connection control and fixup
        ' button caption
        CurrentProject.Connection. _
         Properties( "Jet OLEDB:Connection Control" ) =  2 
        cmdShutdown.Caption = adhcDisallowUsers
    End If
End Sub

Private Sub Form_Load()
    Me.TimerInterval = Me!txtRefresh *  1000 
    Call BuildUserList
    
    ' Check if new users are allowed
    ' and adjust caption of cmdShutdown
    ' accordingly.
    If CurrentProject.Connection. _
     Properties( "Jet OLEDB:Connection Control" ) =  2  Then
        cmdShutdown.Caption = adhcDisallowUsers
    Else
        cmdShutdown.Caption = adhcAllowUsers
    End If
End Sub

Private Sub Form_Timer()
    Call BuildUserList
End Sub

Private Sub txtRefresh_AfterUpdate()
    Me.TimerInterval = Me!txtRefresh *  1000 
End Sub