VBA Retrieve the name of the user associated with logged username

Question

I want to get the full name of the user (logged in already) in VBA. This code I found online would do getting the username:

UserName = Environ(\"USERNAME\")          


        

Answer 1

Even if this thread is rather old, other users might be still googling around (like me). I found an excellent short solution that worked for me out-of-the-box (thanks to Mr.Excel.com). I changed it because I needed it to return a string with the user's full name. The original post is here.

EDIT: Well, I fixed a mistake, "End Sub" instead of "End Function" and added a variable declaration statement, just in case. I tested it in Excel 2010 and 2013 versions. Worked fine on my home pc too (no domain, just in a workgroup).

' This function returns the full name of the currently logged-in user
Function GetUserFullName() as String
    Dim WSHnet, UserName, UserDomain, objUser
    Set WSHnet = CreateObject("WScript.Network")
    UserName = WSHnet.UserName
    UserDomain = WSHnet.UserDomain
    Set objUser = GetObject("WinNT://" & UserDomain & "/" & UserName & ",user")
    GetUserFullName = objUser.FullName
End Function

Answer 2

This works for me. It might need some adjustments - I get several items returned and only one has .Flags > 0

Function GetUserFullName() As String
    Dim objWin32NLP As Object
    On Error Resume Next
    ' Win32_NetworkLoginProfile class  https://msdn.microsoft.com/en-us/library/aa394221%28v=vs.85%29.aspx
    Set objWin32NLP = GetObject("WinMgmts:").InstancesOf("Win32_NetworkLoginProfile")
    If Err.Number <> 0 Then
      MsgBox "WMI is not installed", vbExclamation, "Windows Management Instrumentation"
      Exit Function
    End If
    For Each objItem In objWin32NLP
       If objItem.Flags > 0 Then GetUserFullName = objItem.FullName
    Next
End Function

Answer 3

Try this:

How To Call NetUserGetInfo from Visual Basic

(From Microsoft Knowledge Base, article ID 151774)

The NetUserGetInfo function is a Unicode-only Windows NT API. The last parameter of this function is a pointer to a pointer to a structure whose members contain DWORD data and pointers to Unicode strings. In order to call this function correctly from a Visual Basic application, you need to de-reference the pointer returned by the function and then you need to convert the Visual Basic string to a Unicode string and vice versa. This article illustrates these techniques in an example that calls NetUserGetInfo to retrieve a USER_INFO_3 structure from a Visual Basic application.

The example below uses the Win32 RtlMoveMemory function to de-reference the pointer returned by the NetUserGetInfo call.

Step-by-Step Example

1. Start Visual Basic. If Visual Basic is already running, from the File menu, choose New Project. Form1 is created by default.
2. Add a Command button, Command1, to Form1.
3. Add the following code to the General Declarations section of Form1:

' definitions not specifically declared in the article:

' the servername and username params can also be declared as Longs,
' and passed Unicode memory addresses with the StrPtr function.
Private Declare Function NetUserGetInfo Lib "netapi32" _
                              (ByVal servername As String, _
                              ByVal username As String, _
                              ByVal level As Long, _
                              bufptr As Long) As Long

Const NERR_Success = 0

Private Declare Sub MoveMemory Lib "kernel32" Alias _
      "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Private Declare Function lstrlenW Lib "kernel32" (lpString As Any) As Long

' Converts a Unicode string to an ANSI string
' Specify -1 for cchWideChar and 0 for cchMultiByte to return string length.
Private Declare Function WideCharToMultiByte Lib "kernel32" _
                           (ByVal codepage As Long, _
                           ByVal dwFlags As Long, _
                           lpWideCharStr As Any, _
                           ByVal cchWideChar As Long, _
                           lpMultiByteStr As Any, _
                           ByVal cchMultiByte As Long, _
                           ByVal lpDefaultChar As String, _
                           ByVal lpUsedDefaultChar As Long) As Long


Private Declare Function NetApiBufferFree Lib "netapi32" _
         (ByVal Buffer As Long) As Long

' CodePage
Const CP_ACP = 0        ' ANSI code page

Private Type USER_INFO_3
   usri3_name As Long              'LPWSTR in SDK
   usri3_password As Long          'LPWSTR in SDK
   usri3_password_age As Long      'DWORD in SDK
   usri3_priv As Long              'DWORD in SDK
   usri3_home_dir As Long          'LPWSTR in SDK
   usri3_comment As Long           'LPWSTR in SDK
   usri3_flags As Long             'DWORD in SDK
   usri3_script_path As Long       'LPWSTR in SDK
   usri3_auth_flags As Long        'DWORD in SDK
   usri3_full_name As Long         'LPWSTR in SDK
   usri3_usr_comment As Long       'LPWSTR in SDK
   usri3_parms As Long             'LPWSTR in SDK
   usri3_workstations As Long      'LPWSTR in SDK
   usri3_last_logon As Long        'DWORD in SDK
   usri3_last_logoff As Long       'DWORD in SDK
   usri3_acct_expires As Long      'DWORD in SDK
   usri3_max_storage As Long       'DWORD in SDK
   usri3_units_per_week As Long    'DWORD in SDK
   usri3_logon_hours As Long       'PBYTE in SDK
   usri3_bad_pw_count As Long      'DWORD in SDK
   usri3_num_logons As Long        'DWORD in SDK
   usri3_logon_server As Long      'LPWSTR in SDK
   usri3_country_code As Long      'DWORD in SDK
   usri3_code_page As Long         'DWORD in SDK
   usri3_user_id As Long           'DWORD in SDK
   usri3_primary_group_id As Long  'DWORD in SDK
   usri3_profile As Long           'LPWSTR in SDK
   usri3_home_dir_drive As Long    'LPWSTR in SDK
   usri3_password_expired As Long  'DWORD in SDK
End Type


Private Sub Command1_Click()
Dim lpBuf As Long
Dim ui3 As USER_INFO_3

' Replace "Administrator" with a valid Windows NT user name.
If (NetUserGetInfo("", StrConv("Administrator", vbUnicode), 3, _
uf) = NERR_Success) Then
   Call MoveMemory(ui3, ByVal lpBuf, Len(ui3))

   MsgBox GetStrFromPtrW(ui3.usri3_name)

   Call NetApiBufferFree(ByVal lpBuf)
End If

End Sub

' Returns an ANSI string from a pointer to a Unicode string.

Public Function GetStrFromPtrW(lpszW As Long) As String
Dim sRtn As String

sRtn = String$(lstrlenW(ByVal lpszW) * 2, 0)   ' 2 bytes/char

' WideCharToMultiByte also returns Unicode string length
'  sRtn = String$(WideCharToMultiByte(CP_ACP, 0, ByVal lpszW, -1, 0, 0, 0, 0), 0)

Call WideCharToMultiByte(CP_ACP, 0, ByVal lpszW, -1, ByVal sRtn, Len(sRtn), 0, 0)
GetStrFromPtrW = GetStrFromBufferA(sRtn)

End Function

' Returns the string before first null char encountered (if any) from an ANSI string.

Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
   GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
   ' If sz had no null char, the Left$ function
   ' above would return a zero length string ("").
   GetStrFromBufferA = sz
End If
End Function

I would recommend re-factoring this into a module rather than embedding it in the form itself. I've used this successfully in Access in the past.

Answer 4

I've tried so many things, but I suppose my organization does not allow me to query Active Directory (or I got the structure wrong). I could only get my account name (not full name) or the error "No mapping between account names and security IDs was done"

But after 2 weeks searching, I finally have a working solution that I wanted to share. My final hint can be found here: https://www.mrexcel.com/board/threads/application-username-equivalent-in-ms-access.1143798/page-2#post-5545265

The value does appear in the registry i.e. "HKEY_CURRENT_USER\Software\Microsoft\Office\Common\UserInfo\UserName"

Once I realized that, it was easy to access with VBA:

UserName = CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\Office\Common\UserInfo\UserName")

I assume (did not test though) that this is what Application.Username from Excel uses as well. Might not be perfect, but I finally have a solution that works.

Answer 5

I found the API answer complex as well in addition to needing recoding from a form to module

The function below comes courtesy of Rob Sampson from this Experts-Exchange post. It is a flexible function, see code comments for details. Please note it was a vbscript so the variables are not dimensioned

Sub Test()
    strUser = InputBox("Please enter a username:")
    struserdn = Get_LDAP_User_Properties("user", "samAccountName", strUser, "displayName")
    If Len(struserdn) <> 0 Then
        MsgBox struserdn
    Else
        MsgBox "No record of " & strUser
    End If
End Sub

Function Get_LDAP_User_Properties(strObjectType, strSearchField, strObjectToGet, strCommaDelimProps)

' This is a custom function that connects to the Active Directory, and returns the specific
' Active Directory attribute value, of a specific Object.
' strObjectType: usually "User" or "Computer"
' strSearchField: the field by which to seach the AD by. This acts like an SQL Query's WHERE clause.
'             It filters the results by the value of strObjectToGet
' strObjectToGet: the value by which the results are filtered by, according the strSearchField.
'             For example, if you are searching based on the user account name, strSearchField
'             would be "samAccountName", and strObjectToGet would be that speicific account name,
'             such as "jsmith".  This equates to "WHERE 'samAccountName' = 'jsmith'"
' strCommaDelimProps: the field from the object to actually return.  For example, if you wanted
'             the home folder path, as defined by the AD, for a specific user, this would be
'             "homeDirectory".  If you want to return the ADsPath so that you can bind to that
'             user and get your own parameters from them, then use "ADsPath" as a return string,
'             then bind to the user: Set objUser = GetObject("LDAP://" & strReturnADsPath)

' Now we're checking if the user account passed may have a domain already specified,
' in which case we connect to that domain in AD, instead of the default one.
    If InStr(strObjectToGet, "\") > 0 Then
        arrGroupBits = Split(strObjectToGet, "\")
        strDC = arrGroupBits(0)
        strDNSDomain = strDC & "/" & "DC=" & Replace(Mid(strDC, InStr(strDC, ".") + 1), ".", ",DC=")
        strObjectToGet = arrGroupBits(1)
    Else
        ' Otherwise we just connect to the default domain
        Set objRootDSE = GetObject("LDAP://RootDSE")
        strDNSDomain = objRootDSE.Get("defaultNamingContext")
    End If

    strBase = "<LDAP://" & strDNSDomain & ">"
    ' Setup ADO objects.
    Set adoCommand = CreateObject("ADODB.Command")
    Set ADOConnection = CreateObject("ADODB.Connection")
    ADOConnection.Provider = "ADsDSOObject"
    ADOConnection.Open "Active Directory Provider"
    adoCommand.ActiveConnection = ADOConnection


    ' Filter on user objects.
    'strFilter = "(&(objectCategory=person)(objectClass=user))"
    strFilter = "(&(objectClass=" & strObjectType & ")(" & strSearchField & "=" & strObjectToGet & "))"

    ' Comma delimited list of attribute values to retrieve.
    strAttributes = strCommaDelimProps
    arrProperties = Split(strCommaDelimProps, ",")

    ' Construct the LDAP syntax query.
    strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
    adoCommand.CommandText = strQuery
    ' Define the maximum records to return
    adoCommand.Properties("Page Size") = 100
    adoCommand.Properties("Timeout") = 30
    adoCommand.Properties("Cache Results") = False

    ' Run the query.
    Set adoRecordset = adoCommand.Execute
    ' Enumerate the resulting recordset.
    strReturnVal = ""
    Do Until adoRecordset.EOF
        ' Retrieve values and display.
        For intCount = LBound(arrProperties) To UBound(arrProperties)
            If strReturnVal = "" Then
                strReturnVal = adoRecordset.Fields(intCount).Value
            Else
                strReturnVal = strReturnVal & vbCrLf & adoRecordset.Fields(intCount).Value
            End If
        Next
        ' Move to the next record in the recordset.
        adoRecordset.MoveNext
    Loop

    ' Clean up.
    adoRecordset.Close
    ADOConnection.Close
    Get_LDAP_User_Properties = strReturnVal

End Function