Блог

Я хочу получить полное имя пользователя (уже вошедшего в систему) в VBA. Этот код, который я нашел в Интернете, позволит получить имя пользователя:

 UserName = Environ("USERNAME") 
  

но мне нужно настоящее имя пользователя. Я нашел некоторый намек на NetUserGetInfo, но не уверен, что думать или делать. Любые подсказки будут оценены
С уважением,

Даже если этот поток довольно старый, другие пользователи могут все еще искать в Google (например, я). Я нашел отличное короткое решение, которое сработало для меня из коробки (благодаря Mr.Excel.com ). Я изменил его, потому что мне нужно было, чтобы оно возвращало строку с полным именем пользователя. Исходное сообщение находится здесь.

РЕДАКТИРОВАТЬ: Ну, я исправил ошибку: «End Sub» вместо «End Function» и на всякий случай добавил оператор объявления переменной. Я тестировал его в версиях Excel 2010 и 2013. На моем домашнем компьютере тоже все работало нормально (без домена, только в рабочей группе).

 ' 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://" amp; UserDomain amp; "/" amp; UserName amp; ",user")
    GetUserFullName = objUser.FullName
End Function
  

Я также нашел сложный ответ API в дополнение к необходимости перекодирования из формы в модуль

Приведенная ниже функция предоставлена Робом Сэмпсоном из этого сообщения Experts-Exchange . Это гибкая функция, подробности см. В комментариях к коду. Пожалуйста, обратите внимание, что это был vbscript, поэтому переменные не имеют размеров

 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 " amp; 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://" amp; 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 amp; "/" amp; "DC=" amp; 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://" amp; strDNSDomain amp; ">"
    ' 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 = "(amp;(objectCategory=person)(objectClass=user))"
    strFilter = "(amp;(objectClass=" amp; strObjectType amp; ")(" amp; strSearchField amp; "=" amp; strObjectToGet amp; "))"

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

    ' Construct the LDAP syntax query.
    strQuery = strBase amp; ";" amp; strFilter amp; ";" amp; strAttributes amp; ";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 amp; vbCrLf amp; 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
  

Это работает для меня. Возможно, потребуются некоторые корректировки — я получаю несколько возвращенных элементов, и только один имеет .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(v=vs.85).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
  

Попробуйте это:

Как вызвать NetUserGetInfo из Visual Basic

(Из базы знаний Microsoft, идентификатор статьи 151774)

Функция NetUserGetInfo — это API Windows NT только для Unicode. Последним параметром этой функции является указатель на указатель на структуру, члены которой содержат данные DWORD и указатели на строки Unicode. Чтобы правильно вызвать эту функцию из приложения Visual Basic, вам необходимо отменить ссылку на указатель, возвращаемый функцией, а затем преобразовать строку Visual Basic в строку Unicode и наоборот. Эта статья иллюстрирует эти методы в примере, который вызывает NetUserGetInfo для извлечения структуры USER_INFO_3 из приложения Visual Basic.

В приведенном ниже примере используется функция Win32 RtlMoveMemory для отмены ссылки на указатель, возвращаемый вызовом NetUserGetInfo.

Пошаговый пример

1. Запустите Visual Basic. Если Visual Basic уже запущен, в меню Файл выберите Новый проект. Form1 создается по умолчанию.
2. Добавьте командную кнопку, Command1 , в Form1 .
3. Добавьте следующий код в раздел общих объявлений 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
  

Я бы рекомендовал преобразовать это в модуль, а не встраивать его в саму форму. Я успешно использовал это в Access в прошлом.

Я перепробовал так много вещей, но я полагаю, что моя организация не позволяет мне запрашивать Active Directory (или я неправильно понял структуру). Я мог получить только имя своей учетной записи (не полное имя) или ошибку «Не было выполнено сопоставление между именами учетных записей и идентификаторами безопасности»

Но после 2 недель поиска у меня наконец есть рабочее решение, которым я хотел поделиться. Мой последний совет можно найти здесь: https://www.mrexcel.com/board/threads/application-username-equivalent-in-ms-access.1143798/page-2#post-5545265

Значение действительно отображается в реестре, т.е. «HKEY_CURRENT_USER Software Microsoft Office Common userInfo UserName»

Как только я понял это, к нему было легко получить доступ с помощью VBA:

 UserName = CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USERSoftwareMicrosoftOfficeCommonUserInfoUserName")
  

Я предполагаю (хотя и не проверял), что это то, что Application.Username также используется в Excel. Может быть, это не идеально, но у меня наконец-то есть решение, которое работает.