excel - 从全球通讯录中获取电话号码

Question

在 Outlook 中使用VBA我正在尝试从全球通讯录中获取电话号码。

不幸的是，最常用的方法——遍历整本书——对我的目的来说是不可行的，因为 GAL 中的地址数量太大了。因此，有必要找到具有特定查询的用户。我研究了使用CDO会话以及ADODB方法，但两者都没有按预期工作。任何人都可以提供一个代码片段，使用电子邮件地址作为搜索字符串可以实现上述目标吗？

谢谢

Answer 1

下面两种方法

第一个代码针对用户指定的域在excel中转储了大部分 GAL 详细信息- 它使用变体数组因此速度非常快

您应该更改此行（我已对其进行了清理）以添加您的域

Domains = Array("'LDAP://a.b.example.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://b.c.example.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://d.e.example.org//dc=d,dc=e,dc=example,dc=org'")

代码

Sub DumpGAl()
    Dim ws As Worksheet
    Dim X
    Dim Domains
    Dim Fields
    Dim VarDomains
    Dim VarFields
    Dim objRecordSet
    Dim i As Long
    Dim lngCnt As Long
    Dim lngCnt2 As Long

    Set ws = ThisWorkbook.Sheets(1)
    ws.UsedRange.ClearContents

      Domains = Array("'LDAP://a.b.example.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://b.c.example.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://d.e.example.org//dc=d,dc=e,dc=example,dc=org'")`
    Fields = Array("Last", "First", "Initials", "Company", "physicalDeliveryOfficeName", "Address", "City", "State", "Zip code", "Country", "Phone", "Title", "Department", "Distinguished Name", "Manager", "Email Address", "Mobile Phone", "Cost Centre", "Department", "sAMAccountName", "userPrincipalName", "msExchAssistantName")
    lngCnt = 1
    Set objConnection = CreateObject("ADODB.Connection")
    Set objcommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objcommand.ActiveConnection = objConnection
    objcommand.Properties("Page Size") = 1000
    'For Each VarDomains In Domains
    '    objCommand.CommandText = "Select department, l, title, telephonenumber, givenName, sn, initials, department, displayname, name, mobile, sAMAccountName," _
         '                             & "physicalDeliveryOfficeName, streetAddress, st, postalCode, c, company, distinguishedName, manager, mail, example, userPrincipalName, msExchAssistantName " _
         '                             & "FROM " & VarDomains _
         '                             & "WHERE objectCategory='user'"

    '   Set objRecordSet = objCommand.Execute
    '   lngCnt = lngCnt + objRecordSet.RecordCount
    'Next

    ReDim X(1 To 200001, 1 To 22)
    For Each VarFields In Fields
        lngCnt2 = lngCnt2 + 1
        X(1, lngCnt2) = VarFields
    Next

    i = 2
    Set objConnection = CreateObject("ADODB.Connection")
    Set objcommand = CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objcommand.ActiveConnection = objConnection
    objcommand.Properties("Page Size") = 1000

    For Each VarDomains In Domains
        objcommand.CommandText = "Select department, l, title, telephonenumber, givenName, sn, initials, department, displayname, name, mobile, sAMAccountName," _
                                 & "physicalDeliveryOfficeName, streetAddress, st, postalCode, c, company, distinguishedName, manager, mail, example, userPrincipalName, msExchAssistantName " _
                                 & "FROM " & VarDomains _
                                 & "WHERE objectCategory='user'"

        Set objRecordSet = objcommand.Execute
        objRecordSet.MoveFirst
        Do Until objRecordSet.EOF
            If Not IsNull(Len(objRecordSet.Fields("sn").Value)) Then X(i, 1) = Trim(Replace(Replace(objRecordSet.Fields("sn").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("givenName").Value)) Then X(i, 2) = Trim(Replace(Replace(objRecordSet.Fields("givenName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("initials").Value)) Then X(i, 3) = Trim(Replace(Replace(objRecordSet.Fields("initials").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("company").Value)) Then X(i, 4) = Trim(Replace(Replace(objRecordSet.Fields("company").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("physicalDeliveryOfficeName").Value)) Then X(i, 5) = Trim(Replace(Replace(objRecordSet.Fields("physicalDeliveryOfficeName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("streetAddress").Value)) Then X(i, 6) = Trim(Replace(Replace(objRecordSet.Fields("streetAddress").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("l").Value)) Then X(i, 7) = Trim(Replace(Replace(objRecordSet.Fields("l").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("st").Value)) Then X(i, 8) = Trim(Replace(Replace(objRecordSet.Fields("st").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("postalCode").Value)) Then X(i, 9) = Trim(Replace(Replace(objRecordSet.Fields("postalCode").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("c").Value)) Then X(i, 10) = Trim(Replace(Replace(objRecordSet.Fields("c").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("telephoneNumber").Value)) Then X(i, 11) = Trim(Replace(Replace(objRecordSet.Fields("telephoneNumber").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("title").Value)) Then X(i, 12) = Trim(Replace(Replace(objRecordSet.Fields("title").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("department").Value)) Then X(i, 13) = Trim(Replace(Replace(objRecordSet.Fields("department").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("distinguishedName").Value)) Then X(i, 14) = Trim(Replace(Replace(objRecordSet.Fields("distinguishedName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("manager").Value)) Then X(i, 15) = Trim(Replace(Replace(objRecordSet.Fields("manager").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("mail").Value)) Then X(i, 16) = Trim(Replace(Replace(objRecordSet.Fields("mail").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("mobile").Value)) Then X(i, 17) = Trim(Replace(Replace(objRecordSet.Fields("mobile").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("example").Value)) Then X(i, 18) = Trim(Replace(Replace(objRecordSet.Fields("role").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("department").Value)) Then X(i, 19) = Trim(Replace(Replace(objRecordSet.Fields("department").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("sAMAccountName").Value)) Then X(i, 20) = Trim(Replace(Replace(objRecordSet.Fields("sAMAccountName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("userPrincipalName").Value)) Then X(i, 21) = Trim(Replace(Replace(objRecordSet.Fields("userPrincipalName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            If Not IsNull(Len(objRecordSet.Fields("msExchAssistantName").Value)) Then X(i, 22) = Trim(Replace(Replace(objRecordSet.Fields("msExchAssistantName").Value, vbCrLf, vbNullString), vbTab, vbNullString))
            i = i + 1
            If i Mod 100 = 0 Then
                Application.StatusBar = "Processing record " & i
                DoEvents
            End If
            objRecordSet.MoveNext
        Loop
    Next

    ws.[A1:V200001] = X
    Application.StatusBar = vbNullString

    With ws.[a1:v1]
        .Font.Bold = True
        .Font.Size = 12
        .Font.Name = "Arial"
    End With
    ws.UsedRange.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
End Sub

2. 您可以通过 检索它Active Directory。

下面的代码返回我的电话号码，为我搜索通配符电子邮件地址David.Y.XXX*

我从 Excel 运行下面的代码

下面的关键代码片段，该Get_LDAP_User_Properties功能由 Rob Sampson 提供。

调用子

Sub Main()
MsgBox Get_LDAP_User_Properties("user", "mail", "David.Y.XXX*", "telephoneNumber")
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