Outlook中存在同名Exchange用户时，如何获取其邮箱地址数组？

问题场景 #

我使用了一段Excel VBA函数查询Exchange用户的邮箱地址，但公司内存在多名完全同名（名和姓均相同）的Exchange用户，当解析这类用户名（例如"Pinco Pallino"）时，myRecipient.Resolved返回False，无法获取任何结果。需要修改函数，使其返回所有匹配该用户名的用户邮箱地址数组。

原函数代码如下：

Function lookupEmail(name)
    lookupEmail = ""
    Dim objApp As New Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.recipient
    
    Set myNamespace = objApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient(name)
    
    myRecipient.Resolve
    If myRecipient.Resolved Then
        lookupEmail = GetSMTPAdress(myRecipient)
 
    End If
End Function

Function GetSMTPAdress(recipient As Outlook.recipient)
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
     Set pa = recipient.PropertyAccessor
     GetSMTPAdress = pa.GetProperty(PR_SMTP_ADDRESS)
End Function

修改后的解决方案 #

直接使用CreateRecipient.Resolve无法处理多匹配结果，我们可以通过遍历Exchange全局地址列表（GAL），筛选出姓名匹配的用户，收集他们的SMTP地址并返回数组。

修改后的完整代码：

Function lookupEmail(name As String) As Variant
    Dim objApp As New Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim gal As Outlook.AddressList
    Dim addrEntry As Outlook.AddressEntry
    Dim matchedEmails As Collection
    Dim emailArr() As String
    Dim i As Integer
    
    Set myNamespace = objApp.GetNamespace("MAPI")
    ' 获取Exchange全局地址列表
    Set gal = myNamespace.AddressLists("Global Address List")
    Set matchedEmails = New Collection
    
    ' 遍历地址列表，筛选姓名匹配的用户
    For Each addrEntry In gal.AddressEntries
        ' 大小写不敏感匹配显示名称，可根据需求调整匹配规则
        If LCase(addrEntry.Name) = LCase(name) Then
            ' 仅处理Exchange内部/远程用户
            If addrEntry.AddressEntryUserType = olExchangeUserAddressEntry Or _
               addrEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
                matchedEmails.Add GetSMTPAdress(addrEntry)
            End If
        End If
    Next addrEntry
    
    ' 将集合转为数组返回
    If matchedEmails.Count > 0 Then
        ReDim emailArr(1 To matchedEmails.Count)
        For i = 1 To matchedEmails.Count
            emailArr(i) = matchedEmails(i)
        Next i
        lookupEmail = emailArr
    Else
        ' 无匹配时返回空数组
        lookupEmail = Array()
    End If
    
    ' 释放对象
    Set addrEntry = Nothing
    Set gal = Nothing
    Set myNamespace = Nothing
    Set objApp = Nothing
End Function

Function GetSMTPAdress(addrEntry As Outlook.AddressEntry) As String
    Dim exchUser As Outlook.ExchangeUser
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    
    On Error Resume Next
    ' 优先通过ExchangeUser对象获取SMTP地址，兼容性更好
    Set exchUser = addrEntry.GetExchangeUser
    If Not exchUser Is Nothing Then
        GetSMTPAdress = exchUser.PrimarySmtpAddress
    Else
        '  fallback：用PropertyAccessor读取属性
        Set pa = addrEntry.PropertyAccessor
        GetSMTPAdress = pa.GetProperty(PR_SMTP_ADDRESS)
    End If
    On Error GoTo 0
    
    Set exchUser = Nothing
    Set pa = Nothing
End Function

关键说明 #

• 遍历全局地址列表（Global Address List），替代原方法的单结果解析逻辑；
• 增加用户类型过滤，仅处理Exchange内部或远程用户，排除非Exchange地址；
• 支持大小写不敏感匹配，可根据实际需求调整匹配规则（比如匹配姓/名的部分字段）；
• 返回结果为数组：有匹配时返回所有SMTP地址，无匹配时返回空数组；
• 优化GetSMTPAdress函数，优先使用ExchangeUser.PrimarySmtpAddress获取地址，提升兼容性。

使用示例 #

在Excel VBA中调用测试：

Sub TestLookup()
    Dim emails As Variant
    emails = lookupEmail("Pinco Pallino")
    
    If UBound(emails) >= 0 Then
        For i = LBound(emails) To UBound(emails)
            Debug.Print emails(i) ' 在立即窗口输出所有匹配的邮箱地址
        Next i
    Else
        Debug.Print "未找到匹配的用户"
    End If
End Sub

内容的提问来源于stack exchange，提问作者user1653963