带有Excel VBA的Outlook 2010 GAL

我有以下代码从Excel中获取Outlook的联系人：

Public Sub GetGAL() Dim olApp As Outlook.Application Dim olNs As Outlook.Namespace Dim olFldr As Outlook.Items Dim olContact As Outlook.ContactItem Set olApp = CreateObject("Outlook.Application.14") Set olNs = olApp.GetNamespace("MAPI") Set olFldr = olNs.GetDefaultFolder(olFolderContacts).Items For Each olContact In olFldr Debug.Print olContact.FullName Next olContact End End Sub 

在这一行上说没有types不匹配：

 For Each olContact In olFldr 

有人知道为什么吗？

另外，我如何访问GAL，而不仅仅是我自己的联系人？

谢谢你的帮助。

编辑：这是我的新代码访问addressEntry和ExchangeUser，但是，不是国家领域呢：

 Option Explicit Public Sub GetGAL() Application.ScreenUpdating = False Dim olApp As Outlook.Application Dim olNs As Outlook.Namespace Dim olGAL As Outlook.addressEntries Dim olAddressEntry As Outlook.addressEntry Dim olUser As Outlook.ExchangeUser Dim i As Long 'Dim sTemp As String 'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1) Set olApp = CreateObject("Outlook.Application.14") Set olNs = olApp.GetNamespace("MAPI") Set olGAL = olNs.addressLists("Global Address List").addressEntries 'On Error Resume Next For i = 1 To olGAL.Count Set olAddressEntry = olGAL.Item(i) If olAddressEntry.DisplayType = olRemoteUser Then Set olUser = olAddressEntry.GetExchangeUser 'Debug.Print olUser.Name & ";" & olUser.StateOrProvince 'Debug.Print sTemp 'ws.Cells(i, 1) = olUser.Name 'ws.Cells(i, 2) = olUser.StateOrProvince End If Next i End Application.ScreenUpdating = True End Sub 

Answer 1

试试这个。 虽然如果您的GAL中有大量的条目，需要一段时间才能完成，您可能需要增加65000条。

 Sub tgr() Dim appOL As Object Dim oGAL As Object Dim oContact As Object Dim oUser As Object Dim arrUsers(1 To 65000, 1 To 2) As String Dim UserIndex As Long Dim i As Long Set appOL = CreateObject("Outlook.Application") Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries For i = 1 To oGAL.Count Set oContact = oGAL.Item(i) If oContact.AddressEntryUserType = 0 Then Set oUser = oContact.GetExchangeUser If Len(oUser.lastname) > 0 Then UserIndex = UserIndex + 1 arrUsers(UserIndex, 1) = oUser.Name arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress End If End If Next i appOL.Quit If UserIndex > 0 Then Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers End If Set appOL = Nothing Set oGAL = Nothing Set oContact = Nothing Set oUser = Nothing Erase arrUsers End Sub 

Answer 2

您的代码假定您只能在该文件夹中具有ContactItem对象。 如果遇到DistListItemtypes的对象，它会中断。

将itemvariables声明为一个通用的Object，然后检查Type属性或使用TypeName函数来确定确切的项目types。

编辑：PR_BUSINESS_ADDRESS_COUNTRY DASL名称是

 http://schemas.microsoft.com/mapi/proptag/0x3A26001F 

对于地址条目，您可以在OutlookSpy中看到DALS属性名称。 例如，你可以点击IMAPISessionbutton，点击QueryIdentity，select一个属性，看看DASL编辑框。