Vba 将发件人更改为使用“代表发送”

情景：

两个团队：主团队和帮助团队

MainTeam专门使用共享邮箱，宏“代表MainTeam”发送所有电子邮件，而不是作为共享邮箱发送

帮助团队用户将帮助其他团队。他们需要指明电子邮件是“代表MainTeam”发送的

共享邮箱已添加到HelpingTeam上的用户，在新的邮件窗口中，共享邮箱的电子邮件地址低于其个人邮箱地址。使用此“发件人”地址将表示他们正试图作为邮箱发送，我们不希望这样

我可以向他们展示如何添加另一个“发件人”地址，并将其设置为使用他们的主帐户“SendonBehalfOf”，但他们不想混淆，因为现在他们将在“发件人”列表中看到两个条目：“SendAs”条目（已修复，无法删除）和“SendonBehalfOf”条目（可以删除）

我正在尝试更改电子邮件属性，以便代表共享邮箱发送电子邮件

• 使用此宏从共享邮箱发送电子邮件时，一切正常
• 从个人邮箱启动电子邮件并将发件人更改为“SendAs”帐户（列表中唯一的共享帐户）时，宏中的属性看起来是正确的，但Outlook不处理更改，系统拒绝该邮件

我做了太多的修改，弄不清哪些有效，哪些无效。下面是上述最具功能的版本。MsgBox条目有助于我跟踪幕后发生的事情：

Dim oAccount As Outlook.Account
Dim objItem As MailItem
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Dim Sender As Outlook.AddressEntry

Private Sub Application_Startup()
    Initialize_handler
End Sub

Public Sub Initialize_handler()
    Set objInspectors = Application.Inspectors
    Set myOlExp = Application.ActiveExplorer
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    If Inspector.CurrentItem.Class = olMail Then
        Set objMailItem = Inspector.CurrentItem
        If objMailItem.Sent = False Then
            Call SetFromAddress(objMailItem)
        End If
    End If
End Sub

Public Sub SetFromAddress(objMailItem As Outlook.MailItem)
    'To see which account user is trying to send from
    MsgBox "[SetFromAddress] SendUsingAccount: " & objMailItem.SendUsingAccount
    MsgBox "[SetFromAddress] SentOnBehalfOfName: " & objMailItem.SentOnBehalfOfName
    
    'Check which account is in focus as primary
    If objMailItem.SendUsingAccount = "MainTeam@company.com" Then
        MsgBox "sendfromaddress if triggered"
        'set sender to be the Shared Mailbox
        objMailItem.SentOnBehalfOfName = "MainTeam@company.com"
          
        'Find Primary O365 account and use that to send the email "on behalf of"
        For Each oAccount In Application.Session.Accounts
            If oAccount = "U.ser@company.com" Then
                objMailItem.SendUsingAccount = oAccount
            End If
        Next
    End If
    
    MsgBox "SetFromAddress Sending As: " & objMailItem.SendUsingAccount
    MsgBox "SetFromAddress OnBehalf: " & objMailItem.SentOnBehalfOfName
End Sub

'Below enables Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
    Call SetFromAddress(objItem)
End Sub

'Added the sub below in case the user manually switchs from personal to shared mailbox
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    MsgBox "[ItemSend] SendUsingAccount: " & Item.SendUsingAccount
    MsgBox "[ItemSend] SentOnBehalfOfName: " & Item.SentOnBehalfOfName
    
    'Check if Shared Account
    If Item.SentOnBehalfOfName = "MainTeam@company.com" Then
        MsgBox "If triggered"
        'set sender to be the Shared Mailbox
        Item.SentOnBehalfOfName = "MainTeam@company.com"
        
        'Find Primary O365 account and use that to send the email "on behalf of"
        For Each oAccount In Application.Session.Accounts
            If oAccount = "U.ser@company.com" Then
                Item.SendUsingAccount = oAccount
            End If
        Next
    End If
    
    MsgBox "[ItemSend] SendUsingAccount: " & Item.SendUsingAccount
    MsgBox "[ItemSend] SentOnBehalfOfName: " & Item.SentOnBehalfOfName
End Sub

2020年11月30日

这就是我目前处理这个问题的方式，但如果是在线回复，它就会失败：

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
    Dim oAccount As Outlook.Account
    Dim objItem As MailItem
 
    'To test later which account user is trying to send from
    Set SendingAccount = item.SendUsingAccount
        
    'Check if Shared Account
    If SendingAccount = "MainTeam@company.com" Then

        'Intecept email, stop it from sending, and create a new one "on behalf of"
        If TypeOf item Is MailItem Then
            Set objItem = item.Copy
            item.Delete
            Cancel = True
                       
            'set sender to be the Shared Mailbox
            objItem.SentOnBehalfOfName = "MainTeam@company.com"
            
            'Find Primary O365 account and use that to send the email "on behalf of"
            For Each oAccount In Application.Session.Accounts
                If oAccount = "U.ser@company.com" Then
                    objItem.SendUsingAccount = oAccount
                End If
            Next
        End If
        
        'send email
        objItem.Send
    End If
End Sub

---

我必须欺骗Outlook接受

SentOnBehalfOfName

。您的设置可能不同

Dim oAccount As account
常量mailAddressShared=”MainTeam@company.com"
私有子集合名称（）
将项目设置为邮件项目
设置currItem=ActiveInspector.currentItem
Debug.Print currItem.subject
currItem.SentonBehalfName=mailAddressShared
保存项目
端接头
私有子应用程序_ItemSend（ByVal项作为对象，取消作为布尔值）
调试。打印“[ItemSend]SendUsingAccount:&Item.SendUsingAccount”
Debug.Print“[ItemSend]SentonBehalfName:”&Item.SentonBehalfName
将复制项作为对象
'检查是否存在共享帐户
如果Item.SentonBehalfName=mailAddressShared，则
'诱使Outlook接受。SentonBehalfName
Set copiedItem=Item.Copy
'分配共享邮箱
copiedItem.sentonBehalfName=mailAddressShared
Debug.Print“copiedItem.SentOnBehalfOfName:&copiedItem.SentOnBehalfOfName
ElseIf Item.SentOnBehalfOfName=”“然后
如果MsgBox（“将共享邮箱分配给SentonBehalfName？”，vbYesNo）=vbYes，则
'诱使Outlook接受。SentonBehalfName
Set copiedItem=Item.Copy
'分配共享邮箱
copiedItem.sentonBehalfName=mailAddressShared
Debug.Print“copiedItem.SentOnBehalfOfName:&copiedItem.SentOnBehalfOfName
如果结束
如果结束
'查找发送电子邮件的默认帐户
如果不是，那么他们什么都不是
项目.删除
Cancel=True'取消原始项目
对于会话中的每个OAAccount.Accounts
如果oAccount=Session.GetDefaultFolder（olFolderInbox）.Parent，则
copiedItem.SendUsingAccount=oAccount
退出
如果结束
下一个
调试。打印“[ItemSend]copiedItem.SendUsingAccount:&copiedItem.SendUsingAccount”
Debug.Print“[ItemSend]copiedItem.sentonBehalfName:&copiedItem.sentonBehalfName
copiedItem.Send不会重新触发ItemSend
其他的
调试.打印“[ItemSend]Item.SendUsingAccount:&Item.SendUsingAccount”
Debug.Print“[ItemSend]Item.SentonBehalfName:”&Item.SentonBehalfName
对于会话中的每个OAAccount.Accounts
如果oAccount=Session.GetDefaultFolder（olFolderInbox）.Parent，则
Item.SendUsingAccount=OAAccount
退出
如果结束
下一个
调试.打印“[ItemSend]Item.SendUsingAccount:&Item.SendUsingAccount”
如果结束
端接头

看来我找到了一个很棒的工作！虽然不是答案，但它至少让这段代码起作用。我基本上发送了检查名称

SendKeys“%k”

（ALT+k）的命令，它同时检查sender和recipients字段。当CTRL+k检查新邮件的名称时，它会在回复时打开“插入超链接”窗口，这就是我选择ALT+k的原因

我在SetFromAddress的末尾添加了这个，并在for语句中检查正确的发送帐户。我在语句的内部和外部都进行了测试，但内部每次都有效

Public Sub SetFromAddress(objMailItem As Outlook.MailItem)
    'To see which account user is trying to send from
    
    'Check which account is in focus as primary
    If objMailItem.SendUsingAccount = "MainTeam@company.com" Then
        'set sender to be the Shared Mailbox
        objMailItem.SentOnBehalfOfName = "MainTeam@company.com"
          
        'Find Primary O365 account and use that to send the email "on behalf of"
        For Each oAccount In Application.Session.Accounts
            If oAccount = "U.ser@company.com" Then
                objMailItem.SendUsingAccount = oAccount
            End If
        Next
    End If
    SendKeys "%k
End Sub

及

---

它不是完美的，但在我能够找出如何处理在线响应之前，它将暂时起作用。

.SentonBehalfName

在邮件发送或在代码中分配之前是空的。如果足够重要，用户将运行代码在每封邮件上分配它。验证ItemSend中是否为空，然后用户将分配一个值。嗨，尼顿！谢谢你的帮助！我尝试了复制部分，它在大多数情况下都有效，但当邮件是在线回复时失败。当“发件人”地址的属性更改时，我还试图找到一种方法来更新SendOnRepresentation，但我也无法捕获它。Re:in-line reply-我试图通过切换预览窗格来解决此问题。它使Outlook崩溃了。Re:看来你证实了我之前的经历。“

.SentOnBehalfOfName

在邮件发送或分配到中之前为空。”

            For Each oAccount In Application.Session.Accounts
                If oAccount = "U.ser@company.com" Then
                    objItem.SendUsingAccount = oAccount
                    sendkeys (%k)
                End If
            Next
        End If