Can you please try this modified version, I am getting rid of the NULL character Chr(0) that I think breaks the string in the msgbox:
Code:
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i As Long, j As Long
Dim gsDbs As DAO.Database, gsMsgText As String, gsMsgResponse As String
Set cn = CurrentProject.Connection
Debug.Print CurrentProject.Name
Dim tbl As TableDef, fld
Set gsDbs = CurrentDb
Set tbl = gsDbs.CreateTableDef("Users")
Set fld = tbl.CreateField("User", dbText)
' 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
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
gsMsgText = ""
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
If Not rs.EOF And rs.BOF Then
rs.MoveFirst
End If
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
If Len(gsMsgText) > 0 Then
gsMsgText = gsMsgText & vbCrLf
End If
gsMsgText = gsMsgText & Replace(Trim(rs.Fields(0)), Chr(0), "") & " " & Replace(Trim(rs.Fields(1)), Chr(0), "")
rs.MoveNext
Wend
'TODO: need to validate that the full list is indeed showing
If Len(gsMsgText) = 0 Then
gsMsgText = "no one else has it open"
End If
gsMsgResponse = MsgBox(gsMsgText, vbInformation, "LIST OF CURRENT USERS")
'MsgBox gsMsgText, vbInformation, "LIST OF CURRENT USERS"
End Sub
Cheers,