Office365环境下用Word VBA获取Outlook联系人标准邮箱地址

使用Microsoft Office 365环境，尝试通过Word VBA检索Outlook联系人中对应Word文档内姓名的邮箱地址，期望输出格式为Surname, Name <email address>;;，但当前获取到的是/o=ExchangeLabs/ou=Exchange Administrative Group....这类Exchange专有格式地址，需要获取类似nameSurname@gmail.com的标准SMTP邮箱格式。

以下是当前使用的Word VBA代码：

Option Explicit
Sub SendEmail()
    Dim Names As String
    Dim Doc As Word.Document
    Dim rng As Word.Range
    
    Set Doc = ActiveDocument
    Names = Selection.Text
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Move Unit:=wdStory, Count:=1
    Selection.Text = vbNewLine
    
    Dim OL As Outlook.Application
    Dim EmailItem As Outlook.MailItem
    Dim Rec As Outlook.Recipient
    
    ' Check if Outlook is already open
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    ' If Outlook is not open, create a new instance
    If OL Is Nothing Then
        Set OL = New Outlook.Application
    End If
    
    Set EmailItem = OL.CreateItem(olMailItem)
    
    With EmailItem
        .Display
        .CC = Names
        
        ' Ensure names are properly formatted
        Dim RecipientsResolved As Boolean
        RecipientsResolved = .Recipients.ResolveAll
        
        If Not RecipientsResolved Then
            MsgBox "One or more recipients could not be resolved. Please check the names and try again.", vbExclamation
        End If
        
        For Each Rec In .Recipients
            Selection.Collapse Direction:=wdCollapseEnd
            Selection.Text = Rec.Name & " <" & Rec.Address & ">; "
            Selection.Collapse Direction:=wdCollapseEnd
        Next Rec
     End With
    
    Set OL = Nothing
    Set EmailItem = Nothing
End Sub

问题原因 #

对于Exchange环境中的收件人，Rec.Address返回的是Exchange内部专有格式地址，而非标准SMTP地址，需要通过AddressEntry对象提取对应的SMTP地址。

解决方案 #

修改代码中获取邮箱地址的逻辑，通过判断收件人类型分别处理Exchange用户和普通SMTP收件人，同时调整输出格式匹配需求：

修改后的完整代码 #

Option Explicit
Sub SendEmail()
    Dim Names As String
    Dim Doc As Word.Document
    Dim rng As Word.Range
    
    Set Doc = ActiveDocument
    Names = Selection.Text
    ' 去除文本末尾可能的换行/空格，避免解析错误
    Names = Trim(Replace(Names, vbCrLf, ""))
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Move Unit:=wdStory, Count:=1
    Selection.Text = vbNewLine
    
    Dim OL As Outlook.Application
    Dim EmailItem As Outlook.MailItem
    Dim Rec As Outlook.Recipient
    Dim smtpAddress As String
    Dim exchUser As Outlook.ExchangeUser
    
    ' 检查Outlook是否已打开
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    ' 未打开则新建实例
    If OL Is Nothing Then
        Set OL = New Outlook.Application
    End If
    
    Set EmailItem = OL.CreateItem(olMailItem)
    
    With EmailItem
        .CC = Names
        
        ' 解析所有收件人
        Dim RecipientsResolved As Boolean
        RecipientsResolved = .Recipients.ResolveAll
        
        If Not RecipientsResolved Then
            MsgBox "部分收件人无法解析，请检查姓名后重试。", vbExclamation
        End If
        
        For Each Rec In .Recipients
            ' 初始化SMTP地址变量
            smtpAddress = ""
            ' 判断收件人地址类型
            If Rec.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or _
               Rec.AddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
                ' 处理Exchange用户，获取主SMTP地址
                Set exchUser = Rec.AddressEntry.GetExchangeUser()
                If Not exchUser Is Nothing Then
                    smtpAddress = exchUser.PrimarySmtpAddress
                    Set exchUser = Nothing
                End If
            Else
                ' 非Exchange用户，直接取SMTP格式地址
                smtpAddress = Rec.Address
            End If
            
            ' 输出符合要求的格式
            If smtpAddress <> "" Then
                Selection.Collapse Direction:=wdCollapseEnd
                Selection.Text = Rec.Name & " <" & smtpAddress & ">;; "
                Selection.Collapse Direction:=wdCollapseEnd
            End If
        Next Rec
     End With
    
    ' 释放对象
    Set OL = Nothing
    Set EmailItem = Nothing
End Sub

关键修改点 #

1. Exchange收件人处理：通过Rec.AddressEntry.GetExchangeUser().PrimarySmtpAddress获取Exchange用户的标准SMTP邮箱地址
2. 兼容非Exchange收件人：判断地址类型，直接返回普通SMTP收件人的地址
3. 格式匹配：将输出格式调整为用户期望的Surname, Name <email address>;;
4. 文本预处理：对选中的姓名文本做Trim和换行符去除，避免解析失败

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