Question

我想在VBA中获取用户的全名（已登录）。我在网上找到的这段代码会得到用户名：

UserName = Environ("USERNAME")

但我想要用户的真实姓名。我发现了一些关于NetUserGetInfo的提示，但不确定该做什么或做什么。任何提示将不胜感激的问候，

Answer 1

除了需要从表单重新编码到模块

之外，我还发现API答案很复杂

以下功能来自于此Experts-Exchange post的Rob Sampson。这是一个灵活的功能，详见代码注释。请注意它是一个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）。我改变它是因为我需要它返回一个带有用户全名的字符串。原帖是here。

编辑：好吧，我修正了一个错误，“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

尝试this：

如何从Visual Basic调用NetUserGetInfo

（来自Microsoft知识库，文章ID 151774）

NetUserGetInfo函数是仅限Unicode的Windows NT API。此函数的最后一个参数是指向结构的指针，该结构的成员包含DWORD数据和指向Unicode字符串的指针。为了从Visual Basic应用程序正确调用此函数，您需要取消引用该函数返回的指针，然后您需要将Visual Basic字符串转换为Unicode字符串，反之亦然。本文在一个示例中说明了这些技术，该示例调用NetUserGetInfo从Visual Basic应用程序检索USER_INFO_3结构。

下面的示例使用Win32 RtlMoveMemory函数来取消引用NetUserGetInfo调用返回的指针。

分步示例

启动Visual Basic。如果Visual Basic已在运行，请从“文件”菜单中选择“新建项目”。默认情况下会创建Form1。
将命令按钮Command1添加到Form1。
将以下代码添加到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中成功使用过它。

Answer 4

这对我有用。它可能需要一些调整 - 我返回了几个项目，只有一个项目有.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 5

我已经尝试了很多事情，但是我想我的组织不允许我查询Active Directory（或者我弄错了结构）。我只能得到我的帐户名（不是全名）或错误“没有完成帐户名和安全ID之间的映射”

但是经过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_USER\Software\Microsoft\Office\Common\UserInfo\UserName")

我假设（虽然未测试）Excel也使用Application.Username。可能并不完美，但我终于有了一个可行的解决方案。

VBA检索与记录的用户名关联的用户的名称

5 个答案:

如何从Visual Basic调用NetUserGetInfo