VBA Récupérer le nom de l'utilisateur associé au nom d'utilisateur enregistré

Question

Je veux obtenir le nom complet de l'utilisateur (déjà connecté) en VBA. Ce code que j'ai trouvé en ligne permettrait d'obtenir le nom d'utilisateur :

UserName = Environ("USERNAME") 

mais je veux le vrai nom de l'utilisateur. J'ai trouvé quelques indications sur NetUserGetInfo mais je ne sais pas trop quoi penser ou faire. Tout conseil sera apprécié. Merci,

Answer 1

Même si ce fil de discussion est assez ancien, d'autres utilisateurs sont peut-être encore en train de faire des recherches (comme moi). J'ai trouvé une excellente solution courte qui a fonctionné pour moi dès le départ (merci à M. Excel.com ). Je l'ai changé parce que j'avais besoin qu'il renvoie une chaîne avec le nom complet de l'utilisateur. Le message original est aquí .

EDIT : Bon, j'ai corrigé une erreur, "End Sub" au lieu de "End Function" et ajouté une déclaration de variable, juste au cas où. Je l'ai testé dans les versions 2010 et 2013 d'Excel. Cela a bien fonctionné sur mon ordinateur personnel aussi (pas de domaine, juste dans un groupe de travail).

' 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

J'ai trouvé que la réponse de l'API était également complexe et qu'elle nécessitait un recodage d'un formulaire vers un module.

La fonction ci-dessous est une courtoisie de Rob Sampson à partir de ce site. Poste d'échange d'experts . Il s'agit d'une fonction flexible, voir les commentaires du code pour plus de détails. Veuillez noter qu'il s'agit d'un vbscript et que les variables ne sont pas dimensionnées.

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

Answer 3

Cela fonctionne pour moi. Il faudrait peut-être l'ajuster - je reçois plusieurs articles retournés et un seul a .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 4

Essayez este :

Comment appeler NetUserGetInfo depuis Visual Basic ?

(Extrait de la base de connaissances Microsoft, article ID 151774)

La fonction NetUserGetInfo est une API Windows NT uniquement en Unicode. Le dernier paramètre de cette fonction est un pointeur vers une structure dont les membres contiennent des données DWORD et des pointeurs vers des chaînes Unicode. Afin d'appeler cette fonction correctement à partir d'une application Visual Basic, vous devez déréférencer le pointeur renvoyé par la fonction, puis convertir la chaîne Visual Basic en chaîne Unicode et vice versa. Cet article illustre ces techniques dans un exemple qui appelle NetUserGetInfo pour récupérer une structure USER_INFO_3 à partir d'une application Visual Basic.

L'exemple ci-dessous utilise la fonction Win32 RtlMoveMemory pour déréférencer le pointeur renvoyé par l'appel NetUserGetInfo.

Exemple étape par étape

1. Lancez Visual Basic. Si Visual Basic est déjà en cours d'exécution, dans le menu Fichier, choisissez Nouveau projet. Form1 est créé par défaut.
2. Ajoutez un bouton de commande, Command1 à Form1 .

3. Ajoutez le code suivant à la section General Declarations de l'application 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

Je recommanderais de refactoriser cela dans un module plutôt que de l'intégrer dans le formulaire lui-même. J'ai utilisé cette méthode avec succès dans Access dans le passé.

Answer 5

J'ai essayé tant de choses, mais je suppose que mon organisation ne me permet pas d'interroger Active Directory (ou je me suis trompé dans la structure). Je n'ai pu obtenir que le nom de mon compte (pas le nom complet) ou l'erreur suivante "Aucun mappage entre les noms de compte et les ID de sécurité n'a été fait"

Mais après deux semaines de recherche, j'ai enfin trouvé une solution qui fonctionne et je voulais la partager. Mon astuce finale peut être trouvée ici : https://www.mrexcel.com/board/threads/application-username-equivalent-in-ms-access.1143798/page-2#post-5545265

La valeur apparaît dans le registre, à savoir "HKEY_CURRENT_USER \Software\Microsoft\Office\Common\UserInfo\UserName "

Une fois que j'ai compris cela, il était facile d'y accéder avec VBA :

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

Je suppose (mais je n'ai pas testé) que c'est ce que les Application.Username de l'utilisation d'Excel également. Ce n'est peut-être pas parfait, mais j'ai enfin une solution qui fonctionne.