Private Sub cmdShowUsers_Click()

    Dim rst As New ADODB.Recordset
    Dim i, j As Long

    Set cnn = CurrentProject.Connection
    ' The user roster is exposed as a provider-specific schema rowset
    ' in the Jet 4 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

    Set rst = cnn.OpenSchema(adSchemaProviderSpecific, _
    , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

    strList = BuildString(rst)
    lstUsers.RowSource = strList

End Sub

Private Function BuildString(rst As ADODB.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer

    rst.MoveFirst

    varItems = rst.GetRows()
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            If Not IsNull(varItems(y, x)) Then
            strReturn = strReturn & Left$(varItems(y, x), Len(Trim(varItems(y, x))) - 1) & ";"
            End If

        Next y
    Next x
    BuildString = strReturn
End Function

'Originally written for Access 2 by Mark Nally
'Revised an updated for Access 97 by:

'ACG Soft Consulting Group
'http://ourworld.compuserve.com/homepages/attac-cg
'mailto: [email protected]
'-----------------------------------------------------------------
'This Software was distributed as "Freeware" by the
'original author.  ACG Soft Consulting Group also is distributing
'this Software free of charge, for use by any developer or end user
'provided the attribution contained in the modules of the
'Software are maintained.

'This Software is provided "As Is" without warranty of any kind.  ACG Soft
'Consulting Group expressly disclaims any warrenty regarding
'merchantablity, performance or usability for any purpose whatsoever.
'ACG Soft Consulting Group disclaims all liability for any damages,
'or loss including loss of data, or loss of business profits from use or inability
'to use the Software or any other pecuniary loss real, consequential or otherwise
'arrising in the course of use of this Software.
'--------------------------------------------------------------
' Declare a record type to break down the user info

Private Type UserRec
   bMach(1 To 32) As Byte  ' 1st 32 bytes hold machine name
   bUser(1 To 32) As Byte  ' 2nd 32 bytes hold user name
End Type

Private Sub Form_Open(Cancel As Integer)
   
   Me.LoggedOn.RowSource = WhosOn()

End Sub

Private Sub OKBtn_Click()
   
   DoCmd.Close A_FORM, "frmLoggedOn"

End Sub

Private Sub UpdateBtn_Click()

    Me.LoggedOn.RowSource = WhosOn()

End Sub

'-------------------------------------------------------------------------------------
'   Subject : WhosOn()
'   Purpose : Will read *.LDB file and read who's currently
'             logged on and their station name.
'
'             The LDB file has a 64 byte record.
'
'             The station name starts at byte 1 and is null
'             terminated.
'
'             Log-in names start at the 33rd byte and are
'             also null terminated.
'
'             I had to change the way the file was accessed
'             because the Input() function did not return
'             nulls, so there was no way to see where the
'             names ended.
'-------------------------------------------------------------------------------------
Private Function WhosOn() As String

On Error GoTo Err_WhosOn

   Dim iLDBFile As Integer, iStart As Integer
   Dim iLOF As Integer, i As Integer
   Dim sPath As String, x As String
   Dim sLogStr As String, sLogins As String
   Dim sMach As String, sUser As String
   Dim rUser As UserRec    ' Defined in General
   Dim dbCurrent As Database

' Get Path of current database.  Should substitute this code
' for an attached table path in a multi-user environment.

   Set dbCurrent = DBEngine.Workspaces(0).Databases(0)
   sPath = dbCurrent.Name
   dbCurrent.Close

' Iterate thru dbCurrent.LDB file for login names.

   sPath = Left(sPath, InStr(1, sPath, ".")) + "LDB"

' Test for valid file, else Error

   x = Dir(sPath)
   iStart = 1
   iLDBFile = FreeFile

   Open sPath For Binary Access Read Shared As iLDBFile
   iLOF = LOF(iLDBFile)
   Do While Not EOF(iLDBFile)
      Get iLDBFile, , rUser
      With rUser
         i = 1
         sMach = ""
         While .bMach(i) <> 0
            sMach = sMach & Chr(.bMach(i))
            i = i + 1
         Wend
         i = 1
         sUser = ""
         While .bUser(i) <> 0
            sUser = sUser & Chr(.bUser(i))
            i = i + 1
         Wend
      End With
      sLogStr = sMach & " -- " & sUser
      If InStr(sLogins, sLogStr) = 0 Then
         sLogins = sLogins & sLogStr & ";"
      End If
      iStart = iStart + 64 'increment to next record offset
   Loop
   Close iLDBFile
   WhosOn = sLogins
   
   Set dbCurrent = Nothing

Exit_WhosOn:
   Exit Function

Err_WhosOn:
   If Err = 68 Then
      MsgBox "Couldn't populate the list", 48, "No LDB File"
   Else
      MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
      Close iLDBFile
   End If
   Resume Exit_WhosOn

End Function

Private Sub cmdUpdateUsers_Click()
   Call GetCurrentUsers
End Sub

Private Sub Form_Load()
   Call GetCurrentUsers
End Sub

Private Sub GetCurrentUsers()

    Dim rst As New ADODB.Recordset
    Dim i, j As Long

    Set cnn = CurrentProject.Connection
    ' The user roster is exposed as a provider-specific schema rowset
    ' in the Jet 4 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

    Set rst = cnn.OpenSchema(adSchemaProviderSpecific, _
    , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

    strList = BuildString(rst)
    lstUsers.RowSource = strList

    rst.Close
    Set rst = Nothing

End Sub

Private Function BuildString(rst As ADODB.Recordset) As String
    Dim strReturn As String
    Dim varItems As Variant
    Dim x As Integer
    Dim y As Integer

    'Build list box column headers from Jet 4 OLE DB schema
    'rowset column names.
    strReturn = "COMPUTER_NAME;" & "LOGIN_NAME;" & "CONNECTED;"

    rst.MoveFirst

    varItems = rst.GetRows()
    For x = LBound(varItems, 2) To UBound(varItems, 2)
        For y = LBound(varItems, 1) To UBound(varItems, 1)
            If Not IsNull(varItems(y, x)) Then
            strReturn = strReturn & Left$(varItems(y, x), Len(Trim(varItems(y, x))) - 1) & ";"
            End If

        Next y
    Next x
    BuildString = strReturn
End Function