Schema Userroster

[yont11]

I am attempting to use code to tell me who is logged on to a shared database. It is set up so that the result is sent to a list box. The problem is it is only returning one user even if there are 5 users logged on. The code I am using is below. Can anyone see why it is not listing all users?
Thanks.

Option Compare Database
Option Explicit

Public Const JET_SCHEMA_USERROSTER = _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}"
-----------------------------------------------------------
Public Function ReturnUsers() As String
Dim Conn As ADODB.Connection
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
Set Conn = New ADODB.Connection
On Error GoTo HandleErr
'Open connection to the database
Conn.Open "Provider = Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=G:\Database\My Database.mdb"
'Open schema recordset to grab user metadata
Set rst = Conn.OpenSchema(adSchemaProviderSpecific, , _
JET_SCHEMA_USERROSTER)
'return current users
rst.MoveFirst
Do Until rst.EOF
ReturnUsers = rst(0) & ";" & ReturnUsers
rst.MoveNext
Loop

ExitHere:
rst.close
Set rst = Nothing
Conn.close
Set Conn = Nothing
Exit Function
HandleErr:
MsgBox "Error " & Err.Number & ": " & _
Err.Description
Resume ExitHere

End Function

 

[Zion7]

I can't remember what I did hear exactly but,
I recall some of the the fields had leading LineFeeds,
so I trimed/replaced them?
Maybe peruse my code, & try trim or replace as I did?

Function fLoggedOn() As Boolean
On Error GoTo xxx

Dim cn As New ADODB.Connection
Dim rec As New ADODB.Recordset, x As Integer
Dim JSUR As String, JSIS As String, JSRCT As String, JSRPFL As String
Dim strConnected As String, intMe As Integer
Dim strMessage As String
Dim strCompu As String, strUser As String

JSUR = "{947bb102-5d43-11d1-bdbf-00c04fb92675}" 'JET_SCHEMA_USERROSTER

cn.Open fRCnxn

Set rec = cn.OpenSchema(adSchemaProviderSpecific, , JSUR)

strConnected = "Computer User" & vbCrLf & _
"------------ ----"

While Not rec.EOF
If Trim(rec.Fields(0)) = Environ("COMPUTERNAME") Then intMe = intMe + 1
If intMe <> 1 Then
strCompu = Trim(rec.Fields(0)): strUser = Trim(rec.Fields(1))
strCompu = Replace(strCompu, Chr(0), ""): strUser = Replace(strUser, Chr(0), "")
strConnected = strConnected & vbCrLf & strCompu & " " & strUser
Else
intMe = intMe + 1
End If
rec.MoveNext
Wend

If strCompu = "" Then
fLoggedOn = False
Else
strMessage = strConnected & vbCrLf & vbCrLf & " ...is/are Still Logged Onto the Database!" & vbCrLf & vbCrLf & _
"Can Not Continue, Until All Users have Closed their DataBases!"
MsgBox strMessage, vbOKOnly, "Database Still Open"
fLoggedOn = True
End If


xx:
If rec.State = adStateOpen Then rec.Close: Set rec = Nothing
If cn.State = adStateOpen Then cn.Close: Set cn = Nothing
Exit Function
xxx:
MsgBox Err & vbCrLf & Error$, , "Function; fLoggedOn"
Resume xx
End Function

 

[yont11]

Thanks Zion7 I will give it a try.