从全球通讯录中获取电话号码
在Outlook中使用VBA我试图从全球通讯录中获得一个电话号码。
不幸的是，最常用的方法 – 遍历整本书 – 对于我的目的来说是不可行的，因为GAL中的地址数量太大了。 因此，有必要find具有特定查询的用户。 我看着使用CDO会议，以及ADODB方法，但都没有按预期工作。 任何人都可以提供一个代码片段，使用电子邮件地址作为searchstring可以达到上述目的吗？
谢谢
下面两种方法
第一个代码将大部分GAL细节转储到用户指定的域中，这是因为它使用了不同的数组
你应该改变这一行 – 我已经消毒 – 添加您的域名
Domains = Array("'LDAP://abexample.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://bcexample.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://deexample.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://abexample.org/dc=a,dc=b,dc=example,dc=org'", "'LDAP://bcexample.org//dc=b,dc=c,dc=example,dc=org'", "'LDAP://deexample.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
- 您可以通过
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
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