Outlook VBA转发共享邮箱邮件指定发件人不生效如何解决？

问题根源 #

Outlook 转发来自共享邮箱的邮件时，默认会继承共享邮箱的发件上下文，仅赋值 SendUsingAccount 和 SentOnBehalfOfName 只会修改表层的UI显示，不会触发底层发件配置的刷新，所以直接发送时仍然会用原始邮箱的身份发送。手动切换账号再切回的操作本质是触发了Outlook的配置刷新逻辑，因此能生效。

修复后代码 #

Option Explicit
    
Public Sub SendToQBO()
    Dim objSelection As Selection
    Dim objMail As MailItem
    Dim objForward As MailItem
    Dim objTargetAccount As Account
    Dim strSenderAddr As String
    
    strSenderAddr = "me@mydomain.com"
    
    ' 先遍历获取正确的发件账号，避免按名称索引出错
    For Each objTargetAccount In Session.Accounts
        If LCase(objTargetAccount.SmtpAddress) = LCase(strSenderAddr) Then
            Exit For
        End If
    Next
    ' 未找到对应账号直接退出
    If objTargetAccount Is Nothing Then
        MsgBox "未找到配置的发件账号：" & strSenderAddr, vbCritical
        Exit Sub
    End If
    
    Set objSelection = ActiveExplorer.Selection
    If objSelection.Count = 0 Then Exit Sub
    
    For Each objMail In objSelection
        If TypeName(objMail) = "MailItem" Then
            Set objForward = objMail.Forward
            With objForward
                .To = "mydomain@qbodocs.com"
                .Subject = "Sent From Outlook"
                .Body = objMail.Body
                ' 强制绑定发件账号
                Set .SendUsingAccount = objTargetAccount
                .SentOnBehalfOfName = strSenderAddr
                ' 后台触发配置刷新，用户无感知，代替手动切换账号的操作
                .Display False
                ' 等待Outlook完成配置刷新
                DoEvents
                .Send
            End With
            Set objForward = Nothing
        End If
    Next
End Sub

核心修改说明 #

• 新增发件账号校验逻辑，遍历所有配置的账号匹配SMTP地址，避免因为账号显示名称和地址不一致导致的赋值错误
• 新增 .Display False 调用：带参数False时Outlook会在后台渲染邮件窗口，用户看不到界面，但会触发和手动打开窗口一样的配置刷新逻辑，自动同步发件账号设置
• 新增 DoEvents 等待Outlook完成配置刷新，避免发送操作早于配置更新
• 补充邮件类型判断，避免选中日历、任务等非邮件对象时报错

额外排查项（如果仍有问题） #

• 确认me@mydomain.com是Outlook中独立添加的账号，不是仅通过「添加共享文件夹」挂载的共享邮箱
• 确认该账号的「发送邮件服务器」配置正常，无代理或规则强制修改发件人
• 如果是Office 365环境，可在Exchange管理中心确认me@mydomain.com没有被限制从客户端发送自定义发件人邮件

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