VBA 获取Outlook全球通讯簿GAL用户的头像

获取Exchange的用户头像需要使用IPictureDisp对象的GetPicture()方法。

ExchangeUser.GetPicture 方法 (Outlook) | Microsoft Learny

注意：以下函数需要在Outlook的VBA编辑环境中运行。

本示例的Exchange用户范围条件：选择"ALL Users"。

Sub GetExchangeUserPhoto()

    Dim objPicture As IPictureDisp
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olAL As Outlook.AddressList
    Dim olEntry As Outlook.AddressEntry
    Dim olMember As Outlook.AddressEntry
    Dim lMemberCount As Long
    Dim objMail As Outlook.MailItem
    Dim olUser As Outlook.ExchangeUser
    Set olApp = Outlook.Application
    ' 获取命名空间
    Set olNS = olApp.GetNamespace("MAPI")
    ' 指定地址簿
    Set olAL = olNS.AddressLists("ALL Users")
    Set objMail = olApp.CreateItem(olMailItem)

    ' 获取用户数量
    olALCount = olAL.AddressEntries.Count
    
     ' 遍历全球通讯簿GAL中的每个地址项
    For i = 1 To olALCount
        Set olMember = olAL.AddressEntries.Item(i)
        If olMember Is Nothing Then
            'Do nothing
        Else
           
            'Dim photoStream As IPictureDisp
            Set olUser = olMember.GetExchangeUser
            Set objPicture = olUser.GetPicture

            ' 如果有头像执行保存操作
            If Not objPicture Is Nothing Then
               Dim strFolder As String
    
                ' 设置保存头像的文件夹路径
                strFolder = "C:\Users\admin\Downloads\userphoto\"
                ' 构建保存头像的文件路径
                Dim strFilePath As String
                strFilePath = strFolder & olUser.FirstName & "_" & olUser.LastName & ".jpg"
                '保存图片
                SavePicture objPicture, strFilePath
            End If
    
            Set olUser = Nothing
            Set objPicture = Nothing
            
        End If
               
    Next
    
    Set objMail = Nothing
    Set olAL = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
  
End Sub

 ' 如果需要获取全球通讯簿，可用下面的方法

Dim olGAL As Outlook.AddressList   

Set olGAL = olNS.GetGlobalAddressList

   ' 遍历全球通讯簿中的每个地址项

    For Each olEntry In olGAL.AddressEntries

        ' 仅处理Exchange用户

        If olEntry.AddressEntryUserType = olExchangeUserAddressEntry Then

        End If

    Next olEntry