如何通过Outlook桌面版VBA实现以原发件人身份转发邮件？

现有代码的问题 #

你当前的代码使用SentOnBehalfOfName仅能实现「代表原发件人发送」，存在以下局限：

• 邮件服务器需预先给你配置发送代表权限，否则该设置无效，邮件仍会显示你的地址
• 即使权限配置成功，收件方会看到类似「你的邮箱 代表 abc@gmail.com」的发送者信息，无法完全伪装成原发件人
• 回复默认指向你的邮箱，未修改回复收件人设置

实现方案 #

要让邮件看起来完全来自原发件人，需创建新邮件而非直接转发，同时修改发送者、回复地址等核心属性。注意：此操作需确保你拥有合法代发权限，且符合邮件服务提供商规则，避免触发反垃圾机制。

修正后的VBA代码 #

Sub ForwardAsOriginalSender(objMail As Outlook.MailItem)
    Dim newMail As Outlook.MailItem
    Dim originalSenderAddr As String
    Dim originalSenderName As String
    
    On Error GoTo Cleanup
    
    If objMail.Class <> olMail Then Exit Sub
    
    ' 获取原发件人信息
    originalSenderName = objMail.SenderName
    originalSenderAddr = objMail.SenderEmailAddress
    
    ' 创建新邮件（避免转发自带的标记与属性锁定）
    Set newMail = Application.CreateItem(olMailItem)
    
    ' 设置收件人
    newMail.Recipients.Add "xyz@gmail.com"
    ' 同步原邮件主题
    newMail.Subject = objMail.Subject
    
    ' 复制原邮件格式内容
    newMail.HTMLBody = objMail.HTMLBody
    ' 如需添加转发提示，可取消下方注释
    ' newMail.HTMLBody = "<p><b>转发自：</b>" & originalSenderName & " (" & originalSenderAddr & ")</p><br>" & objMail.HTMLBody
    
    ' 设置代发身份（需对应权限）
    newMail.SentOnBehalfOfName = originalSenderAddr
    ' 关键：设置回复收件人为原发件人，确保回复流向正确
    newMail.ReplyRecipients.Add originalSenderAddr
    
    ' 若拥有原发件人账户登录权限，可指定发送账户（可选）
    ' Dim sendAccount As Outlook.Account
    ' For Each sendAccount In Application.Session.Accounts
    '     If sendAccount.SmtpAddress = originalSenderAddr Then
    '         Set newMail.SendUsingAccount = sendAccount
    '         Exit For
    '     End If
    ' Next
    
    ' 发送邮件
    newMail.Send

Cleanup:
    Set newMail = Nothing
End Sub

关键说明 #

• 创建新邮件而非转发：Forward方法会自动添加转发标记，且部分发送属性被Outlook锁定，无法修改
• 设置回复收件人：通过ReplyRecipients.Add确保收件人回复时，邮件发送至原发件人邮箱而非你的邮箱
• 权限要求：SentOnBehalfOfName生效的前提是，你的邮箱账户被原发件人邮箱管理员授予「发送代表」权限；若要完全以原发件人身份发送（无「代表」标识），则需拥有该账户登录权限，并通过SendUsingAccount指定对应账户
• 内容复制：直接复制原邮件HTMLBody保留格式，可按需添加转发说明

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