VBA Получить имя пользователя, связанного с зарегистрированным именем пользователя.

Question

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

UserName = Environ("USERNAME") 

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

Answer 1

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

Данная функция любезно предоставлена ​​Робом Сэмпсоном из этого сообщения экспертов по обмену . Это гибкая функция, подробности см. В комментариях к коду. Обратите внимание, что это был 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 " & 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 2

Даже если эта тема довольно старая, другие пользователи могут все еще гуглить (например, я).Я нашел отличное короткое решение, которое сработало для меня из коробки (спасибо 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://" & UserDomain & "/" & UserName & ",user")
    GetUserFullName = objUser.FullName
End Function

Answer 3

Это работает для меня. Возможно, потребуется внести некоторые коррективы - я вернул несколько предметов, и только у одного из них .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

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

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

(из базы знаний Майкрософт, идентификатор статьи 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 в прошлом.