如何获取发件人邮箱地址而非姓名？Outlook VBA代码问题

原代码通过ReplyAll邮件的.To属性获取收件人地址时，Outlook会优先显示本地联系人列表里的姓名，而非原始的SMTP邮箱地址。要解决这个问题，得直接遍历收件人集合，逐个提取每个收件人的真实SMTP地址。

以下是修正后的代码：

Dim OutApp As Outlook.Application
Dim outEmail As Outlook.MailItem
Dim replyMail As Outlook.MailItem
Dim recip As Outlook.Recipient
Dim Address As String

Set OutApp = GetObject(, "Outlook.Application")
Set outEmail = OutApp.Session.OpenSharedItem(Filename)

' 创建ReplyAll邮件但不显示
Set replyMail = outEmail.ReplyAll

' 遍历所有收件人，提取SMTP地址
For Each recip In replyMail.Recipients
    recip.Resolve ' 确保收件人信息已解析
    ' 分类型获取SMTP地址
    If recip.AddressEntry.Type = "EX" Then
        ' 处理Exchange邮箱，提取主SMTP地址
        Address = Address & recip.AddressEntry.GetExchangeUser.PrimarySmtpAddress & ";"
    Else
        ' 处理普通SMTP邮箱，直接取地址
        Address = Address & recip.Address & ";"
    End If
Next recip

' 移除末尾多余的分号
If Len(Address) > 0 Then
    Address = Left(Address, Len(Address) - 1)
End If

' 关闭ReplyAll邮件，不保存
replyMail.Close olDiscard

' 创建新邮件，设置收件人为原邮件发件人的真实邮箱地址
Dim newMail As Outlook.MailItem
Set newMail = OutApp.CreateItem(olMailItem)
With newMail
    ' 提取原邮件发件人的SMTP地址
    If outEmail.Sender.AddressEntry.Type = "EX" Then
        .To = outEmail.Sender.AddressEntry.GetExchangeUser.PrimarySmtpAddress
    Else
        .To = outEmail.Sender.Address
    End If
    ' 可按需添加主题、正文等设置
    '.Subject = "跟进：" & outEmail.Subject
    '.Display ' 显示新邮件
End With

' 释放对象
Set newMail = Nothing
Set replyMail = Nothing
Set outEmail = Nothing
Set OutApp = Nothing

重点说明： #

• 别再依赖.Display和.To拿地址，直接遍历收件人集合才能拿到真实的邮箱地址
• 要区分Exchange邮箱和普通SMTP邮箱，两种类型的地址提取逻辑不一样
• 新建邮件时，原邮件发件人的地址也要用同样的方式处理，避免只显示姓名
• 去掉了没必要的.Display调用，代码运行效率更高

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