Наворочено, но работает!
Подход заключается в том, чтобы использовать WMI для отображения активных сеансов, а затем перекрестно ссылаться на сеанс с зарегистрированным именем пользователя. Это можно сделать, выполняя что-то вроде:

'---------------------------------------------------------------------------------------
' Procedure : WMI_GetUsernames
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Return a dictionary (unique values) of usernames for the specified computer
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Входные переменные:
' ~~~~~~~~~~~~~~~~
' sHost     : хост-компьютер для запроса, пропустите для локального ПК
'
' Usage:
' ~~~~~~
'
'
' История изменений:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2018-04-13              Initial Release
'---------------------------------------------------------------------------------------
Public Function WMI_GetUsernames(Optional sHost As String = ".") As Object    'Scripting Dictionary
    'Ref: https://msdn.microsoft.com/en-us/library/aa394189(v=vs.85).aspx
    '     https://msdn.microsoft.com/en-us/library/aa394172(v=vs.85).aspx
    '     https://msdn.microsoft.com/en-us/library/aa384793(v=vs.85).aspx
    On Error GoTo Error_Handler
    Dim oWMI                  As Object    'WMI object to query about the PC's OS
    Dim sWMIQuery             As String    'WMI Query
    Dim oLogonSessions        As Object
    Dim oLogonSession         As Object
    Dim oUsers                As Object
    Dim oUser                 As Object
    Dim dictUsers             As Object    'Scripting Dictionary
 
    Set WMI_GetUsernames = Nothing    'Always empty it!
    Set dictUsers = CreateObject("Scripting.Dictionary")    'New dictionary
    Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2")
    sWMIQuery = "SELECT * " & _
                "FROM Win32_LogonSession " & _
                "WHERE LogonType=2"
    Set oLogonSessions = oWMI.ExecQuery(sWMIQuery)
    For Each oLogonSession In oLogonSessions
        'Теперь, когда у нас есть активные сеансы, давайте узнаем, кто их запускает.
        sWMIQuery = "Associators of " & _
                    "{Win32_LogonSession.LogonId=" & oLogonSession.LogonId & "} " & _
                    "WHERE AssocClass=Win32_LoggedOnUser Role=Dependent"
        Set oUsers = oWMI.ExecQuery(sWMIQuery)
        For Each oUser In oUsers
            With oUser
                '                Debug.Print .Name
                If dictUsers.Exists(.Name) = False Then dictUsers.Add .Name, .Name
            End With
        Next
    Next
    Set WMI_GetUsernames = dictUsers
 
Error_Handler_Exit:
    On Error Resume Next
    Set dictUsers = Nothing
    Set oUsers = Nothing
    Set oUser = Nothing
    Set oLogonSession = Nothing
    Set oLogonSessions = Nothing
    Set oWMI = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: WMI_GetUsernames" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

 
'Вот как это можно использовать!
Sub TestMe()
    Dim User As Variant
'    Dim WMI_GetUsernames As Object
 
    For Each User In WMI_GetUsernames.keys
        Debug.Print User
    Next
End Sub

-------------------------------------------------------------
А ты вложил уже свой кровный рубль в 50-ти миллиардное состояние Билла Гейтса?

http://www.sql.ru/forum/1291602/nayti-imya-polzovatelya-windows-cherez-wmi