Outlook 2010 GAL与Excel VBA

问题描述

  Public Sub GetGAL（）
我有以下代码从Excel中获取Outlook中的联系人
 Dim olApp As Outlook.Application 
 Dim olNs As Outlook.Namespace 
 Dim olFldr As Outlook.Items 
 Dim olContact As Outlook.ContactItem 
 
设置olApp = CreateObject（Outlook.Application.14）
设置olNs = olApp.GetNamespace（MAPI）
 
设置olFldr = olNs.GetDefaultFolder（olFolderContacts）.Items 
 
每个olContact在olFldr 
 
 Debug.Print olContact.FullName 
 
下一个olContact 
 
结束
 End Sub 
  

在这行上失败，表示类型不匹配：

 对于每个olContact在olFldr 
  

有谁知道为什么这是？

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

感谢任何帮助。

编辑：这是我的新代码访问地址Entry和Exc然而，hangeUser不是国家/地区：

  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）
 
设置olApp = CreateObject（Outlook.Application.14）
设置olNs = olApp.GetNamespace（ MAPI）
 
设置olGAL = olNs.address列表（全局地址列表）。addressEntries 
 
'On Error Resume Next 
 
对于i = 1到olGAL.Count 
 
设置olAddressEntry = olGAL.Item（i）
 
如果olAddressEntry.DisplayType = olRemoteUser然后
 
设置olUser = olAddressEntry .GetExchangeUser 
 
'Debug.Print olUser.Name& ; &安培; olUser.StateOrProvince 
'Debug.Print sTemp 
 
'ws.Cells（i，1）= olUser.Name 
'ws.Cells（i，2）= olUser.StateOrProvince 
 
结束如果
 
下一个i 
 
结束
 
 Application.ScreenUpdating = True 
 End Sub 
  

解决方案

尽管如果您的GAL中有吨数吨，您需要一段时间才能完成，您可能需要增加65000。

  Sub tgr（）
 
 Dim appOL As Object 
 Dim oGAL As Object 
 Dim oContact As Object 
 Dim oUser As Object 
 Dim arrUsers 1到65000，1到2）As String 
 Dim UserIndex As Long 
 Dim i As Long 
 
设置appOL = CreateObject（Outlook.Application）
设置oGAL = appOL.GetNameSpace（MAPI）。AddressLists（全局地址列表）AddressEntries 
 
对于i = 1 To oGAL.Count 
设置oContact = oGAL.Item（i） 
如果oContact.AddressEntryUserType = 0然后
设置oUser = oContact.GetExchangeUser 
如果Len（oUser.lastname）> 0然后
 UserIndex = UserIndex + 1 
 arrUsers（UserIndex，1）= oUser.Name 
 arrUsers（UserIndex，2）= oUser.PrimarySMTPAddress 
 End If 
 End如果
 Next i 
 
 appOL.Quit 
 
如果UserIndex> 0然后
范围（A2）。调整大小（UserIndex，UBound（arrUsers，2））。Value = arrUsers 
如果
 
设置appOL = Nothing 
设置oGAL = Nothing 
设置oContact = Nothing 
设置oUser =没有
擦除arrUsers 
 
 End Sub 
  

I have the following code to get contacts out of Outlook from Excel:

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

It is failing on this line saying there is a type mismatch:

For Each olContact In olFldr

Does anyone know why this is?

Also, how do I access the GAL as opposed to just my own contacts?

Thanks for any help.

Edit: Here's my new code to access the addressEntry and ExchangeUser, however, not the country field yet:

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

解决方案

Give this a try. Although if you have tons and tons of entries in your GAL, it will take awhile to complete, and you may have to increase the 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

这篇关于Outlook 2010 GAL与Excel VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！