Enumerate Users Local or Remote
This is a pair of class modules that allow you to easily enumerate the currently logged in users on either the local machine or a specified remote machine.
Class Module: clsGetRemoteLoggedInUsers
This class returns the logged in users on a remote or local Workstation when the HostName property is set by your Program. It requires that the Class clsRemoteUsersInfo be added to project as well.
Option Explicit
'Api Structures
Private Type WKSTA_USER_INFO_1
lngUserName As Long
lngLogonDomain As Long
lngOtherDomains As Long
lngLogonServer As Long
End Type
'Error Constants
Const ERROR_BAD_NETPATH = 53&
Const ERROR_INVALID_NAME = 123&
Const ERROR_NOT_ENOUGH_MEMORY = 8
Const ERROR_INVALID_LEVEL = 124&
Const ERROR_INVALID_PARAMETER = 87
Const ERROR_MORE_DATA = 234
Const NERR_Success As Long = 0&
'Api Declares
Private Declare Function NetWkstaUserEnum Lib "netapi32.dll" _
(ByVal strServerName As String, ByVal dwLevel As Long, _
lpBuffer As Long, ByVal dwPrefMaxLen As Long, _
lpdEntriesRead As Long, lpdTotalEntries As Long, _
lpdResumehandle As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32.dll" _
(ByVal pBuffer As Long) As Long
Private Declare Function NetApiBufferSize Lib "netapi32.dll" _
(lpBuffer As Any, lpLength As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" _
(pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32.dll" _
(ByVal lpString As Long) As Long
'local variable(s) to hold property value(s)
Private mvarNumberOfAccounts As Integer 'local copy
Private mvarServerName As String 'local copy
Private colUserAccounts As New Collection
Dim mvarUserAccounts As Collection 'local copy
Public Property Get UserAccounts() As Variant
If mvarUserAccounts Is Nothing Then
Set mvarUserAccounts = New Collection
End If
Set UserAccounts = mvarUserAccounts
End Property
Public Property Let ServerName(ByVal vData As String)
mvarServerName = vData
GotServerName (mvarServerName)
End Property
Public Property Get ServerName() As String
ServerName = mvarServerName
End Property
Public Property Get NumberOfAccounts() As Integer
NumberOfAccounts = mvarNumberOfAccounts
End Property
Private Function PtrToString(lpwString As Long) As String
'Convert a LPWSTR pointer to a VB string
Dim Buffer() As Byte
Dim nLen As Long
If lpwString Then
nLen = lstrlenW(lpwString) * 2
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMem Buffer(0), ByVal lpwString, nLen
PtrToString = Buffer
End If
End If
End Function
Private Sub GotServerName(ByVal strHostName As String)
Dim lngLevel As Long
Dim lngPrefmaxlen As Long
Dim lngEntriesRead As Long
Dim lngTotalEntries As Long
Dim lngResumeHandle As Long
Dim lngReturn As Long
Dim lngLength As Long
Dim lngBuffer As Long
Dim typWkStaInfo(0 To 1000) As WKSTA_USER_INFO_1
Dim intCount As Integer
Dim CurrentInfo As clsRemoteUsersInfo
'Check for the right syntax for the servername
'Convert it to unicode because the C function wants a LPCWSTR
'ie LongPointer to a unicode string, the C stands for a constants
'vbNullString for the local Machine
If strHostName = "" Then
strHostName = vbNullString
Else
If InStr(strHostName, "\\") <> 0 Then
strHostName = StrConv(strHostName & vbNullChar, vbUnicode)
Else
strHostName = StrConv("\\" & strHostName & vbNullChar, vbUnicode)
End If
End If
'set the resumehandle to the first entry
lngResumeHandle = 0
'Define the new Collection
Set mvarUserAccounts = New Collection
'Call the function, the -1 passed to dwPrefMaxLen lets the function create its
'own buffer that will hold all the data returned, I choose to enumerate at level 1
'you can pass a level 0, feel free to modify
lngReturn = NetWkstaUserEnum(strHostName, &H1, lngBuffer, -1, lngEntriesRead, lngTotalEntries, lngResumeHandle)
'if successful ie NERR_Success get the info
If lngReturn = NERR_Success Then
'initialize the count variable
intCount = 0
'Get the size of the memory allocated
lngReturn = NetApiBufferSize(ByVal lngBuffer, lngLength)
'Copy the memory into the array so we can get the information out
'I imagine this could cause really strange things to happen if you happen to
'have more then 1000 users logged into this workstation. I tried to dump the info into
'a dynamic array and VB keep generating a Doctor Watson error everytime the
'sub exited beats me why, If anybody know email me
CopyMem typWkStaInfo(0), ByVal lngBuffer, lngLength
'Get the info out and add it too are collection
For intCount = 0 To lngTotalEntries - 1
'temporay object to hold the info
Set CurrentInfo = New clsRemoteUsersInfo
'The info returned is actually a LP, which we have to convert
'I used Andrea Tincani's function which transforms the returned LPWSTR to a string
CurrentInfo.Username = PtrToString(typWkStaInfo(intCount).lngUserName)
CurrentInfo.LogonDomain = PtrToString(typWkStaInfo(intCount).lngLogonDomain)
CurrentInfo.LogonServer = PtrToString(typWkStaInfo(intCount).lngLogonServer)
CurrentInfo.OtherDomains = PtrToString(typWkStaInfo(intCount).lngOtherDomains)
'add it to the collection
mvarUserAccounts.Add CurrentInfo, CurrentInfo.Username
'destroy our temporary object
Set CurrentInfo = Nothing
'One more done
intCount = intCount + 1
Next
Else
'our function failed lets find out why
GoTo GetErrMsg
End If
'We have to free up the Memory the funtion allocated for our data
If lngBuffer Then
Call NetApiBufferFree(ByVal lngBuffer)
End If
Exit Sub
GetErrMsg:
ReturnErrorMsg (lngReturn)
End Sub
Private Function ReturnErrorMsg(ByVal errorcode As Long)
Select Case errorcode
Case 53
MsgBox "Error: Bad netpath"
Case 123
MsgBox "Error: Invalid Host Name"
Case 8
MsgBox "Error: Not enough Memory"
Case 124
MsgBox "Error: Invalid Level, you don't have the authority to run this"
Case 87
MsgBox "Error: Invalid Parameter"
Case 234
MsgBox "Error: error more data"
End Select
End Function
Class Module: clsRemoteUsersInfo
Option Explicit
'local variable(s) to hold property value(s)
Private mvarUsername As String
Private mvarLogonDomain As String
Private mvarOtherDomains As String
Private mvarLogonServer As String
Public Property Get LogonServer() As String
LogonServer = mvarLogonServer
End Property
Public Property Let LogonServer(ByVal vData As String)
mvarLogonServer = vData
End Property
Public Property Get OtherDomains() As String
OtherDomains = mvarOtherDomains
End Property
Public Property Let OtherDomains(ByVal vData As String)
mvarOtherDomains = vData
End Property
Public Property Get LogonDomain() As String
LogonDomain = mvarLogonDomain
End Property
Public Property Let LogonDomain(ByVal vData As String)
mvarLogonDomain = vData
End Property
Public Property Get Username() As String
Username = mvarUsername
End Property
Public Property Let Username(ByVal vData As String)
mvarUsername = vData
End Property
Usage
Private Sub Form_Load()
Dim x As New clsGetRemoteLoggedInUsers
Dim y As Variant
'Set the remote hostname to get the logged-in users (blank for the local Computer)
x.ServerName = ""
'Add a listbox named list1 to your project
For Each y In x.UserAccounts
List1.AddItem (y.Username)
List1.AddItem (y.LogonServer)
List1.AddItem (y.LogonDomain)
List1.AddItem (y.OtherDomains)
List1.AddItem ("")
Next
End Sub
About this post
Posted: 2019-10-01
By: JasonBooy
Viewed: 11,797 times
Categories
Attachments
enumerateusers.zip
Posted: 10/1/2019 10:02:25 AM
Size: 4,355 bytes
Special Instructions
This code originally appeared on AndreaVB.com, and has been republished here with the permission of Andrea Tincani.
Loading Comments ...
Comments
No comments have been added for this post.
You must be logged in to make a comment.