API: Return the UserID currently logged on a remote machine

  As shown by the LoggedOn console app, written in C and provided by SysInternals, it's possible to connect to a remote machine's Registry, and enumerate the HKey_Users entries to determine which subtree contains the information about the current user account.

  This code is part of the AppUser utility form which uses the machine name from Jet's LDB file to do a remote lookup on the user id.

AppUser.zip (Access 2000, 67,445 bytes) Please note that these are NT/2000 only API functions.

' ******** Code Start ********
' -----------------------
' The code for retrieving remote user name was
' translated into VBA from source code provided by
' SysInternals - www.sysinternals.com
' Copyright (C) 1999-2000 Mark Russinovich
' as part of the LoggedOn console app
'
' Translated by: Dev Ashish
' www.mvps.org/access
'
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Modified version 2003-26-03 by Andreas Schubert
'   See description of fGetRemoteLoggedUserID function for details
' -----------------------

Private Declare Function apiNetAPIBufferFree _
        Lib "netapi32.dll" Alias "NetApiBufferFree" _
        (ByVal buffer As Long) _
        As Long

Private Declare Function apiFormatMsgLong _
        Lib "kernel32" Alias "FormatMessageA" _
        (ByVal dwFlags As Long, _
         ByVal lpSource As Long, _
         ByVal dwMessageId As Long, _
         ByVal dwLanguageId As Long, _
         ByVal lpBuffer As String, _
         ByVal nSize As Long, _
         Arguments As Long) _
         As Long

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SID_IDENTIFIER_AUTHORITY
    Value(5) As Byte
End Type

Private Declare Function apiRegConnectRegistry _
        Lib "advapi32.dll" Alias "RegConnectRegistryA" _
        (ByVal lpMachineName As String, _
         ByVal hKey As Long, _
         phkResult As Long) _
         As Long

Private Declare Function apiRegEnumKeyEx _
        Lib "advapi32.dll" Alias "RegEnumKeyExA" _
        (ByVal hKey As Long, _
         ByVal dwIndex As Long, _
         ByVal lpName As String, _
         lpcbName As Long, _
         ByVal lpReserved As Long, _
         ByVal lpClass As String, _
         lpcbClass As Long, _
         lpftLastWriteTime As FILETIME) _
         As Long

Private Declare Function apiRegCloseKey _
        Lib "advapi32.dll" Alias "RegCloseKey" _
        (ByVal hKey As Long) _
        As Long

Private Declare Function apiAllocateAndInitializeSid _
        Lib "advapi32.dll" Alias "AllocateAndInitializeSid" _
        (pIdentifierAuthority As SID_IDENTIFIER_AUTHORITY, _
         ByVal nSubAuthorityCount As Byte, _
         ByVal nSubAuthority0 As Long, _
         ByVal nSubAuthority1 As Long, _
         ByVal nSubAuthority2 As Long, _
         ByVal nSubAuthority3 As Long, _
         ByVal nSubAuthority4 As Long, _
         ByVal nSubAuthority5 As Long, _
         ByVal nSubAuthority6 As Long, _
         ByVal nSubAuthority7 As Long, _
         lpPSid As Any) _
         As Long

Private Declare Function apiLookupAccountSid _
        Lib "advapi32.dll" Alias "LookupAccountSidA" _
        (ByVal lpSystemName As String, _
         Sid As Any, _
         ByVal name As String, _
         cbName As Long, _
         ByVal ReferencedDomainName As String, _
         cbReferencedDomainName As Long, _
         peUse As Integer) _
         As Long

Private Declare Function apiIsValidSid _
        Lib "advapi32.dll" Alias "IsValidSid" _
        (pSid As Any) _
        As Long

Private Declare Sub sapiFreeSid _
        Lib "advapi32.dll" Alias "FreeSid" _
                                        (pSid As Any)


Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const ERROR_SUCCESS = 0&
Private Const HKEY_USERS = &H80000003
Private Const MAX_PATH = 260
Private Const ERROR_MORE_DATA = 234
Private Const MAX_NAME_STRING = 1024
Private Const SECURITY_NT_AUTHORITY = 5


Function fGetRemoteLoggedUserID(strMachineName As String) As String
'
' Retrieves the id of the user currently logged into the specified
' local or remote machine in the format DOMAIN\UserName
'
' Usage:
' ?fGetRemoteLoggedUserID("springfield")
'
' Retrieves the id of the user currently logged into the specified
' local or remote machine in the format DOMAIN\UserName
'
' Translated into VBA from source code provided by
' SysInternals - www.sysinternals.com
' Copyright (C) 1999-2000 Mark Russinovich
' as part of the LoggedOn console app
'
' Translated by: Dev Ashish
' www.mvps.org/access
' dev@mvps.org
'
'
' modified 2003-26-03 by: Andreas Schubert
' usenet@andreas-schubert.net
' eliminated a view bugs:
' 1. converting the registry subkey to SubAuthorities sometimes caused an
'       overflow error because of the difference between C's DWORD and VB's Long.
'       so I first convert them to a double and if it exceeds 2147483647,
'       I substract 4294967296 and then convert it to long
'       For j = 3 To lngSubAuthorityCount
'           adblTemp = 0
'           adblTemp = CDbl(astrTmpSubAuthority(j))
'           If adblTemp > 2147483647 Then
'               adblTemp = adblTemp - 4294967296#
'           End If
'           alngSubAuthority(j - 3) = CLng(adblTemp)
'       Next
'
' 2. sometimes a subkey won't consist of 7 parts. If so, the function
'           crashed with an Index error.
'           Solving this was pretty easy by inserting
'       If UBound(alngSubAuthority) < 7 Then ReDim Preserve alngSubAuthority(7)
'
' 3. It is possible that the function finds more than 1 active user
'       at the remote workstation. This may for instance be the cause
'       if you are running an Microsoft SMS Server in your network.
'       The SMS client will run under an local account on your machine
'       (like \Computername\SMSCliSvsAcct)
'       So, I modified the function to get all accounts separated by vbcrlf - character(s)
'

    Dim hRemoteUser As Long, j As Long
    Dim lngRet As Long, i As Long, lngSubKeyNameSize As Long
    Dim strSubKeyName As String
    Dim alngSubAuthority() As Long, astrTmpSubAuthority() As String
    Dim tFT As FILETIME, tAuthority As SID_IDENTIFIER_AUTHORITY
    Dim pSid As Long, lngUserNameSize As Long, lngDomainNameSize As Long
    Dim lngSubAuthorityCount As Long, intSidType As Integer
    Dim strUserName As String, strDomainName As String

    Dim adblTemp As Double
    Const ERR_GENERIC = vbObjectError + 5555
    Const KEY_TO_SKIP_1 = "classes"
    Const KEY_TO_SKIP_2 = ".default"
    On Error GoTo ErrHandler

    lngRet = apiRegConnectRegistry(strMachineName, _
                                   HKEY_USERS, hRemoteUser)
    If lngRet <> ERROR_SUCCESS Then Err.Raise ERR_GENERIC


    For i = 0 To 4
        tAuthority.Value(i) = 0
    Next
    i = 0

    lngSubKeyNameSize = MAX_PATH
    strSubKeyName = String$(lngSubKeyNameSize, vbNullChar)

    lngRet = apiRegEnumKeyEx(hRemoteUser, _
                             i, strSubKeyName, lngSubKeyNameSize, _
                             0, 0, 0, tFT)

    Do While (lngRet = ERROR_SUCCESS Or lngRet = ERROR_MORE_DATA)
        If (InStr(1, strSubKeyName, KEY_TO_SKIP_1, vbTextCompare) = 0 _
            And InStr(1, strSubKeyName, _
            KEY_TO_SKIP_2, vbTextCompare) = 0) Then
            strSubKeyName = Left$(strSubKeyName, lngSubKeyNameSize)
            astrTmpSubAuthority = Split(strSubKeyName, "-")
            lngSubAuthorityCount = UBound(astrTmpSubAuthority)
            ReDim alngSubAuthority(lngSubAuthorityCount)
            For j = 3 To lngSubAuthorityCount
                adblTemp = 0
                adblTemp = CDbl(astrTmpSubAuthority(j))
                If adblTemp > 2147483647 Then
                    adblTemp = adblTemp - 4294967296#
                End If
                alngSubAuthority(j - 3) = CLng(adblTemp)
            Next
            lngSubAuthorityCount = UBound(alngSubAuthority) - 2
            If UBound(alngSubAuthority) < 7 Then ReDim Preserve alngSubAuthority(7)
            With tAuthority
                .Value(5) = SECURITY_NT_AUTHORITY
                .Value(4) = 0
                .Value(3) = 0
                .Value(2) = 0
                .Value(1) = 0
                .Value(0) = 0
            End With

            If (apiAllocateAndInitializeSid(tAuthority, _
                lngSubAuthorityCount, _
                alngSubAuthority(0), _
                alngSubAuthority(1), _
                alngSubAuthority(2), _
                alngSubAuthority(3), _
                alngSubAuthority(4), _
                alngSubAuthority(5), _
                alngSubAuthority(6), _
                alngSubAuthority(7), _
                pSid)) Then

                If (apiIsValidSid(ByVal pSid)) Then
                    lngUserNameSize = MAX_NAME_STRING
                    lngDomainNameSize = MAX_NAME_STRING
                    strUserName = String$(lngUserNameSize - 1, vbNullChar)
                    strDomainName = String$( _
                                            lngDomainNameSize - 1, vbNullChar)
                    lngRet = apiLookupAccountSid(strMachineName, _
                                                 ByVal pSid, _
                                                 strUserName, _
                                                 lngUserNameSize, _
                                                 strDomainName, _
                                                 lngDomainNameSize, _
                                                 intSidType)
                    If (lngRet <> 0) Then
                        fGetRemoteLoggedUserID = fGetRemoteLoggedUserID & fTrimNull(strDomainName) _
                                               & "\" & fTrimNull(strUserName) & vbCrLf
                        'Exit Do
                    Else
                        With Err
                            .Raise .LastDllError, _
                                   "fGetRemoteLoggedUserID", _
                                   fAPIErr(.LastDllError)
                        End With
                    End If
                End If
            End If
            If (pSid) Then Call sapiFreeSid(pSid)
        End If
        i = i + 1
        lngSubKeyNameSize = MAX_PATH
        strSubKeyName = String$(lngSubKeyNameSize, vbNullChar)
        lngRet = apiRegEnumKeyEx(hRemoteUser, _
                                 i, strSubKeyName, lngSubKeyNameSize, _
                                 0, 0, 0, tFT)
    Loop


ExitHere:
    If (pSid) Then Call sapiFreeSid(pSid)
    Call apiRegCloseKey(hRemoteUser)
    Exit Function
ErrHandler:
    With Err
        If .Number <> ERR_GENERIC Then
            MsgBox "Error: " & .Number & vbCrLf & .Description, _
                   vbCritical Or vbOKOnly, .Source
        End If
    End With
    Resume ExitHere
End Function

Private Function fAPIErr(ByVal lngErr As Long) As String
'Original Idea obtained from
'Hardcode Visual Basic 5
'by Bruce McKinney
'
    Dim strMsg As String
    Dim lngRet As Long
    strMsg = String$(1024, 0)
    lngRet = apiFormatMsgLong( _
                              FORMAT_MESSAGE_FROM_SYSTEM, 0&, _
                              lngErr, 0&, strMsg, Len(strMsg), ByVal 0&)
    If lngRet Then
        fAPIErr = Left$(strMsg, lngRet)
    End If
End Function

Private Function fTrimNull(strIn As String) As String
    Dim intPos As Integer
    intPos = InStr(1, strIn, vbNullChar)
    If intPos Then
        fTrimNull = Mid$(strIn, 1, intPos - 1)
    Else
        fTrimNull = strIn
    End If
End Function
' ******** Code End ********