问从Active Directory获取电子邮件地址

EN

Function UserNameToEmail(name1 As String, Optional name2 As String = "")

    Set rootDSE = GetObject("LDAP://RootDSE")
    base = "<LDAP://" & rootDSE.Get("defaultNamingContext") & ">"

    'filter on user objects with the given account name
    fltr = "(&(objectClass=user)(objectCategory=Person)"
    If Len(name2) = 0 Then
        fltr = fltr & "(sAMAccountName=" & name1 & "))"
    Else
        fltr = fltr & "(givenName=" & name1 & ")(sn=" & name2 & "))"
    End If

    'add other attributes according to your requirements
    attr = "mail,department,givenName,sn"
    scope = "subtree"

    Set conn = CreateObject("ADODB.Connection")
    conn.Provider = "ADsDSOObject"
    conn.Open "Active Directory Provider"

    Set cmd = CreateObject("ADODB.Command")
    Set cmd.ActiveConnection = conn
    cmd.CommandText = base & ";" & fltr & ";" & attr & ";" & scope

    Set rs = cmd.Execute

    If Not rs.EOF Then
      For Each f In rs.Fields
        Debug.Print f.Name & ": " & f.Value
      Next f
      UserNameToEmail = rs.Fields("mail").Value
    End If

    rs.Close
    conn.Close

End Function