Link to home
Start Free TrialLog in
Avatar of RIAS
RIASFlag for United Kingdom of Great Britain and Northern Ireland

asked on

Create macro from runcode

Hello,
I have a module as in :
https://support.microsoft.com/en-us/help/285822/how-to-determine-who-is-logged-on-to-a-database-by-using-microsoft-jet-userroster-in-access
I need to create a macro ,so that when the user clicks on the Run macro the results are displayed.
Wnen i tested the code ,i had to open a immediate window to see the results.
is there any way the results are displayed on a form when I run the macro.
 I am using access 2013 .

Cheers
Avatar of Bill Prew
Bill Prew

Give this modification a try, if you don't have a large amount of data returned it may get the job done.  Beyond that it would be a bit more involved to have a form with scrolling output, probably in tabular format...

ub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i, j As Long
    Dim txt As String

    Set cn = CurrentProject.Connection

    ' 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.

    txt = ""

    txt = txt & rs.Fields(0).Name & " " & rs.Fields(1).Name & " " & rs.Fields(2).Name & " " & rs.Fields(3).Name & vbCrLf

    While Not rs.EOF
        txt = txt & rs.Fields(0) & " " & rs.Fields(1) & " " & rs.Fields(2) & " " & rs.Fields(3) & vbCrLf
        rs.MoveNext
    Wend

    MsgBox txt

End Sub

Open in new window

~bp
Avatar of RIAS

ASKER

Cheers Bill! Wil try and brb
Another approach that wouldn't be too hard if you are using this only occasionally for troubleshooting could be to write the txt variable that I have built with the results to a text file on the computer, and then open it in Notepad for viewing.  That would be easy to do, if that could meet your need?

~bp
Avatar of RIAS

ASKER

ok
Avatar of RIAS

ASKER

Bill,
its just giving me the ComputerName and not the login_Name or username?
Is that all you were seeing in the Immediate window (I can't test here), it should be the same results just in a MsgBox instead of the Immediate window.

~bp
Avatar of RIAS

ASKER

Nope,
In immediate window it shows everything,but msgbox just shows the computer name
Avatar of RIAS

ASKER

Output from immediate window :
COMPUTER_NAME               LOGIN_NAME                  CONNECTED     SUSPECT_STATE
PC5                                   Admin                                     True          Null

Open in new window


Output from msgbox

COMPUTER_NAME               LOGIN_NAME                  CONNECTED     SUSPECT_STATE
PC5
Just for a test try this please, it may be some of the those fields have nulls in them and could be affecting the output.  Also check the immediate window and see what it shows.

Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i, j As Long
    Dim txt As String

    Set cn = CurrentProject.Connection

    ' 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.

    txt = ""

    txt = txt & rs.Fields(0).Name & " " & rs.Fields(1).Name & " " & rs.Fields(2).Name & " " & rs.Fields(3).Name & vbCrLf

    While Not rs.EOF
        txt = txt & Replace(rs.Fields(0), Chr(0), " ") & " " & Replace(rs.Fields(1), Chr(0), " ") & " " & Replace(rs.Fields(2), Chr(0), " ") & " " & Replace(rs.Fields(3), Chr(0), " ") & vbCrLf
        rs.MoveNext
    Wend

    Debug.Print txt
    MsgBox txt

End Sub

Open in new window

~bp
Avatar of RIAS

ASKER

Error:
invalid use of null
     txt = txt & Replace(rs.Fields(0), Chr(0), " ") & " " & Replace(rs.Fields(1), Chr(0), " ") & " " & Replace(rs.Fields(2), Chr(0), " ") & " " & Replace(rs.Fields(3), Chr(0), " ") & vbCrLf
   

Open in new window

Okay, let's try a slightly different approach.

Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i, j As Long
    Dim txt As String

    Set cn = CurrentProject.Connection

    ' 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.

    txt = ""

    txt = txt & rs.Fields(0).Name & " " & rs.Fields(1).Name & " " & rs.Fields(2).Name & " " & rs.Fields(3).Name & vbCrLf

    While Not rs.EOF
        txt = txt & Trim(rs.Fields(0).Value) & " " & Trim(rs.Fields(1).Value) & " " & Trim(rs.Fields(2).Value) & " " & Trim(rs.Fields(3.Value) & vbCrLf
        rs.MoveNext
    Wend

    Debug.Print txt
    MsgBox txt

End Sub

Function Clean(s As String)
End Function

Open in new window

~bp
Avatar of RIAS

ASKER

trying..
Avatar of RIAS

ASKER

Nope,
looks like msgbox is just not displaying two values ;
Okay, for a test try the attached.  Adjust the patch for the TXT file it will write as needed in the call to DoWrite.  Then after it runs open the output file in Notepad or your favorite text editor and see what it looks like.

Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i, j As Long
    Dim txt As String

    Set cn = CurrentProject.Connection

    ' 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.

    txt = ""

    txt = txt & rs.Fields(0).Name & " " & rs.Fields(1).Name & " " & rs.Fields(2).Name & " " & rs.Fields(3).Name & vbCrLf

    While Not rs.EOF
        txt = txt & Trim(rs.Fields(0).Value) & " " & Trim(rs.Fields(1).Value) & " " & Trim(rs.Fields(2).Value) & " " & Trim(rs.Fields(3.Value) & vbCrLf
        rs.MoveNext
    Wend

    DoWrite "c:\temp\roster.txt", txt

End Sub

Sub DoWrite(p As String, X As String)
    f = FreeFile
    Open p For Output As #f
    Print #f, X
    Close #f
End Sub

Open in new window

~bp
I think I did confirm that it is nulls in the field data that is messing with MsgBox, based on this simple test.  So perhaps I can find a different way to remove those, trying now...

Sub Test()
    s = "aaa" & Chr(0) & "bbb" & Chr(0) & "ccc"
    MsgBox s
    s = "aaa" & Chr(32) & "bbb" & Chr(32) & "ccc"
    MsgBox s
End Sub

Open in new window

~bp
Avatar of RIAS

ASKER

Bill,
That worked but,a messagebox will be better option.
Can you help?
Yes, let me find a way to get those Null characters out of the fields.

~bp
ASKER CERTIFIED SOLUTION
Avatar of Bill Prew
Bill Prew

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of RIAS

ASKER

trying..
Avatar of RIAS

ASKER

Error:

Invalid use of null

 txt = txt & TrimNull(rs.Fields(0).Value) & " " & TrimNull(rs.Fields(1).Value) & " " & TrimNull(rs.Fields(2).Value) & " " & TrimNull(rs.Fields(3).Value) & vbCrLf

Open in new window

Argh.  Interesting since I did this test here and it seemed to work.  Let me research a bit further...  It appears the nulls in the fields behave a bit differently than nulls in a built string...

Sub Test()
    s = "xxxxxxxxx" & TrimNull("aaa" & Chr(0)) & TrimNull("bbb" & Chr(0)) & TrimNull("ccc" & Chr(0))
    MsgBox s
End Sub

Function TrimNull(s As String) As String
    Dim i As Integer
    i = InStr(s, Chr(0))
    If i > 0 Then
        TrimNull = Left(s, i - 1)
    Else
        TrimNull = s
    End If
End Function

Open in new window

~bp
If you F8 though the one you got the error on, does it ever go into the TrimNull function, or just error on the line that builds the txt variable?

~bp
Avatar of RIAS

ASKER

 just error on the line that builds the txt variable?

Open in new window

Avatar of RIAS

ASKER

Does not build ,it errors on that line
Avatar of RIAS

ASKER

Cheers mate!
Avatar of RIAS

ASKER

Don't thonk I need all parameters so used :

Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim txt As Variant

    Set cn = CurrentProject.Connection

    ' 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.

   
 'Output the list of all users in the current database.

    
    txt = ""

    txt = txt & rs.Fields(0).Name & " ; " & rs.Fields(1).Name & " " & vbCrLf

    While Not rs.EOF
        txt = txt & TrimNull(rs.Fields(0)) & " ;  " & TrimNull(rs.Fields(1)) & "" & vbCrLf
        rs.MoveNext
    Wend

    MsgBox txt

End Sub

Open in new window

Avatar of RIAS

ASKER

Thanks a lot!!!!
Welcome, sorry that was harder than it should have been...

~bp
Avatar of RIAS

ASKER

No worries mate! Thanks !