使用Excel VBA从姓名解析Outlook邮箱地址时遇运行时错误287

我编写了一个Excel VBA脚本，用于遍历电子表格查找未分配任务的员工并发送邮件。之前用Outlook全局地址列表（GAL）的邮箱列表能正常运行，现在人员列表扩大，尝试通过循环中的员工姓名从Outlook获取对应邮箱地址，使用了以下代码：

Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith@myco.com)
    ' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.

    Dim OLApp As Object 'Outlook.Application
    Dim oRecip As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim oEDL As Object 'Outlook.ExchangeDistributionList

    Set OLApp = CreateObject("Outlook.Application")
    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                Dim PR_SMTP_ADDRESS As String
                PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
                ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End Select
    End If
End Function

但执行oRecip.Resolve时出现运行时错误287：应用程序定义或对象定义错误。已知可能和安全权限有关，但找不到相关设置，且其他VBA脚本能正常创建和发送邮件。请问如何解决该错误？是否有其他通过姓名获取公司Outlook邮箱地址的方法？

一、修复运行时错误287的方法 #

1. 改用GetObject获取Outlook实例 #

CreateObject会创建新的Outlook实例，容易触发安全限制。改用GetObject复用已打开的Outlook实例，降低权限拦截概率：

Function ResolveDisplayNameToSMTP(sFromName) As String
    Dim OLApp As Object
    Dim oRecip As Object
    Dim oEU As Object
    
    ' 尝试获取已运行的Outlook实例，失败则创建新实例
    On Error Resume Next
    Set OLApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OLApp Is Nothing Then
        Set OLApp = CreateObject("Outlook.Application")
    End If

    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    ' 添加错误捕获处理解析失败的情况
    On Error Resume Next
    oRecip.Resolve
    On Error GoTo 0
    
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & olSmtpAddressEntry
                Dim PR_SMTP_ADDRESS As String
                PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
                ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End Select
    Else
        ' 解析失败时返回空值
        ResolveDisplayNameToSMTP = ""
    End If
End Function

2. 调整Outlook信任中心设置 #

打开Outlook → 文件 → 选项 → 信任中心 → 信任中心设置 → 程序访问安全：

• 勾选“从不向我发出可疑活动警告”（仅在可信环境下使用）
• 或添加Excel程序到“信任的程序”列表

3. 确保姓名匹配准确 #

GAL中的姓名可能包含中间名、后缀（如Jr.）或部门信息，传入的sFromName需和GAL显示名完全一致，或尝试使用姓, 名格式（如Smith, James）提高解析成功率。

4. 添加错误重试机制 #

部分情况下权限拦截是临时的，可添加重试逻辑：

' 在解析前添加重试
Dim retryCount As Integer
retryCount = 3
Do While retryCount > 0 And Not oRecip.Resolved
    On Error Resume Next
    oRecip.Resolve
    On Error GoTo 0
    retryCount = retryCount - 1
    If Not oRecip.Resolved Then
        Application.Wait Now + TimeValue("00:00:01") ' 等待1秒后重试
    End If
Loop

二、其他获取邮箱地址的方法 #

1. 直接查询Outlook全局地址列表（GAL） #

遍历GAL的地址条目，匹配姓名获取邮箱：

Function GetEmailFromGAL(sName As String) As String
    Dim OLApp As Object
    Dim addrList As Object
    Dim addrEntry As Object
    
    Set OLApp = GetObject(, "Outlook.Application")
    Set addrList = OLApp.Session.AddressLists("Global Address List")
    
    For Each addrEntry In addrList.AddressEntries
        If addrEntry.Name = sName Then
            If addrEntry.AddressEntryUserType = 0 Or addrEntry.AddressEntryUserType = 5 Then
                GetEmailFromGAL = addrEntry.GetExchangeUser.PrimarySmtpAddress
                Exit Function
            End If
        End If
    Next addrEntry
    
    GetEmailFromGAL = ""
End Function

2. 备用方案：Excel维护邮箱映射表 #

如果GAL查询始终有问题，可在Excel中单独维护一张“员工姓名-邮箱”对照表，直接通过查询获取邮箱，避免依赖Outlook权限：

Function GetEmailFromLookup(sName As String) As String
    Dim ws As Worksheet
    Dim lookupRng As Range
    Dim result As Variant
    
    Set ws = ThisWorkbook.Sheets("员工邮箱表")
    Set lookupRng = ws.Range("A:B") ' A列姓名，B列邮箱
    
    result = Application.VLookup(sName, lookupRng, 2, False)
    If Not IsError(result) Then
        GetEmailFromLookup = result
    Else
        GetEmailFromLookup = ""
    End If
End Function

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