如何在现有Outlook VBA模板宏中添加指定账户发件功能

我需要在现有Outlook VBA宏中添加指定账户发送的功能。当前宏可根据用户位置调用对应邮件模板（运行正常），但发件人显示不符合需求：运行宏时，发件人显示为「Toast Los Angeles Sent on Behalf of Toast Los Angeles」，我希望改为「BWS Sent on Behalf of Toast Los Angeles」。

此前我尝试过实现默认账户发件的宏，但该代码仅适用于新建空白邮件，无法适配现有模板，请求帮忙修改代码。

现有宏代码 #

Sub JobCompletion()
Dim Inbox As Object
Dim MyItem As Object
Dim Region As String
Dim RegionB As String
Dim FormTemplate As String

'This code was replaced by Environ("UserName") to be compatible with Win 10
'Select Case fOSUserName()
Select Case Environ("UserName")
  
  'Set up site according to username for LA
  Case "blue", "red", "pink"
  Region = "Toast Los Angeles"
  FormTemplate = "IPM.Note._LA Pres Center Job Complete Notification - IBD"

  'Set up site according to username for HOU
  Case "black", "brown", "gree"
  Region = "Toast Houston"
  FormTemplate = "IPM.Note._HOU Pres Center Job Complete Notification - IBD"
  
  Case Else
  MsgBox "Please Contact Jacob X to add you to the Macro"
  Exit Sub
  
  End Select
  
        'Check Version of Outlook (2007 vs 2010)
            If Outlook.Application.Version = "12.0.0.6680" Then
                On Error GoTo FolderError:
                Set Inbox = Outlook.Application.GetNamespace("MAPI").Folders("Mailbox - " & Region)
                On Error Resume Next
            Else
                On Error GoTo FolderError:
                Set Inbox = Outlook.Application.GetNamespace("MAPI").Folders(Region).Folders("Inbox")
                On Error Resume Next
            End If
    
            'Open Form From Folder (The Inbox =)
            Set MyItem = Inbox.Items.Add(FormTemplate)
            MyItem.SentOnBehalfOfName = Region
            MyItem.Display
  
Set Inbox = Nothing
Set MyItem = Nothing
     
Exit Sub

End Sub

尝试过的新建邮件宏代码 #

Public Sub New_Mail()
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem

Set olNS = Application.GetNamespace("MAPI")
Set oMail = Application.CreateItem(olMailItem)

'use first account in list
    oMail.SendUsingAccount = olNS.Accounts.Item(1)
    oMail.Display
      
Set oMail = Nothing
Set olNS = Nothing

End Sub

修改后的代码及说明 #

核心修改点 #

1. 将MyItem从Object类型改为Outlook.MailItem，确保能调用SendUsingAccount属性
2. 添加账户遍历逻辑，精准定位到「BWS」账户
3. 保留原有的SentOnBehalfOfName设置，实现「指定账户代表区域邮箱发送」的效果
4. 补充错误提示，提升代码容错性

修改后完整代码 #

Sub JobCompletion()
    Dim Inbox As Object
    Dim MyItem As Outlook.MailItem ' 改为明确的MailItem类型，支持SendUsingAccount属性
    Dim Region As String
    Dim FormTemplate As String
    Dim olNS As Outlook.NameSpace
    Dim targetAccount As Outlook.Account ' 定义目标账户变量

    ' 根据用户名匹配区域和模板
    Select Case Environ("UserName")
        ' LA区域用户
        Case "blue", "red", "pink"
            Region = "Toast Los Angeles"
            FormTemplate = "IPM.Note._LA Pres Center Job Complete Notification - IBD"
        ' HOU区域用户
        Case "black", "brown", "gree"
            Region = "Toast Houston"
            FormTemplate = "IPM.Note._HOU Pres Center Job Complete Notification - IBD"
        Case Else
            MsgBox "请联系Jacob X将你添加到宏权限列表"
            Exit Sub
    End Select

    ' 获取MAPI命名空间
    Set olNS = Outlook.Application.GetNamespace("MAPI")

    ' 根据Outlook版本获取对应邮箱文件夹
    If Outlook.Application.Version = "12.0.0.6680" Then
        On Error GoTo FolderError:
        Set Inbox = olNS.Folders("Mailbox - " & Region)
        On Error Resume Next
    Else
        On Error GoTo FolderError:
        Set Inbox = olNS.Folders(Region).Folders("Inbox")
        On Error Resume Next
    End If

    ' 从模板创建邮件
    Set MyItem = Inbox.Items.Add(FormTemplate)
    ' 设置代表发送的名称（保持原逻辑）
    MyItem.SentOnBehalfOfName = Region

    ' 遍历账户列表，找到名为"BWS"的账户
    For Each targetAccount In olNS.Accounts
        If targetAccount.DisplayName = "BWS" Then ' 此处需与Outlook中BWS账户的显示名完全匹配
            MyItem.SendUsingAccount = targetAccount
            Exit For
        End If
    Next targetAccount

    ' 若未找到指定账户，弹出提示
    If targetAccount Is Nothing Then
        MsgBox "未找到名为BWS的账户，请检查Outlook账户配置"
    End If

    MyItem.Display

    ' 释放对象
    Set Inbox = Nothing
    Set MyItem = Nothing
    Set olNS = Nothing
    Set targetAccount = Nothing
    Exit Sub

FolderError:
    MsgBox "无法找到对应邮箱文件夹，请检查账户配置"
    Resume Next
End Sub

使用说明 #

• 确保targetAccount.DisplayName = "BWS"中的BWS与你Outlook账户列表中该账户的显示名完全一致（可在Outlook「文件」→「账户设置」中查看）
• 修改后运行宏，邮件将以「BWS」账户发送，同时显示「Sent on Behalf of [对应区域邮箱]」的效果

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