Author  

Language  

Operating Systems  

Option Explicit

'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

'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

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

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