从特定电子邮件帐户发送时自动“代表发送”

Question

我可以帮助修改 Outlook VBA 宏。每当我从我的多个电子邮件帐户中的任何一个回复电子邮件时，脚本都会将发件人地址更改为指定的地址（即 user@domain.com 代表 group@domain.com）。我喜欢这种行为，但需要帮助进行更改，以便此脚本仅在我从电子邮件地址@domain.com 发送时运行。本质上，我希望宏有一个 if 语句，指定是否从 @domain.com 电子邮件帐户发送然后运行宏，否则如果从另一个电子邮件帐户（即 user@gmail.com）发送不运行宏。

'================================================================================
'Description: Outlook macro to automatically set a different
'             From address.
'
'Comment: You can set the email address at the bottom of the code.
'         Uncomment the myOlExp_InlineResponse sub to also make it
'         work with the Reading Pane reply feature of Outlook 2013/2016/2019/365.
'
' author : Robert Sparnaaij
' version: 1.1
' website: https://www.howto-outlook.com/howto/setfromaddress.htm
'================================================================================

Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer

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

'Uncomment the next 3 lines to enable Outlook 2013/2016/2019/365 Reading Pane Reply
'Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
'    Call SetFromAddress(objItem)
'End Sub

Public Sub SetFromAddress(oMail As Outlook.MailItem)
    ' Set your preferred default From address below.
    ' Exchange permissions determine if it is actually stamped
    ' as "Sent On Behalf Of" or "Sent As".
    ' The address is not properly updated for the InlineResponse
    ' feature in Outlook 2013/2016/365. This is only a visual bug.
    oMail.SentOnBehalfOfName = "delegate@domain.com"
End Sub

Answer 1

如果您想处理外发电子邮件，您需要订阅 Application 类的 ItemSend 事件，只要用户通过检查器发送 Microsoft Outlook 项目就会触发该事件（在检查器关闭之前，但在用户单击“发送”按钮后）或在程序中使用 Outlook 项目（如 MailItem）的 Send 方法时。

Public WithEvents myOlApp As Outlook.Application 
 
Public Sub Initialize_handler()  
 Set myOlApp = Outlook.Application  
End Sub 
 
Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)  
 Dim prompt As String  
 prompt = "Are you sure you want to send " & Item.Subject & "?"  
 If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then  
 Cancel = True  
 End If  
End Sub

在事件处理程序中，您可以查看MailItem.SendUsingAccount 属性，该属性允许设置一个Account 对象，该对象代表将发送MailItem 的帐户。 SendUsingAccount 属性可用于指定在调用 Send 方法时用于发送 MailItem 的帐户。

根据邮件项上设置的帐户，您可能需要设置MailItem.SentOnBehalfOfName 属性，该属性返回一个字符串，指示邮件的预期发件人的显示名称。您可能需要取消默认操作并以编程方式重新提交项目。

Answer 2

将文件夹树向上导航到电子邮件地址文件夹。

这应该是objMailItem.Parent.Parent。

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
        
    If Inspector.currentItem.Class = olMail Then
        Set objMailItem = Inspector.currentItem
        If objMailItem.Sent = False Then
            
            Debug.Print objMailItem.Parent.Parent
            If InStr(LCase(objMailItem.Parent.Parent), LCase("@domain.com")) Then
                Call SetFromAddress(objMailItem)
            End If
            
        End If
    End If
End Sub

Answer 3

对于任何发现此内容的人。 如果您已经在 Outlook 中设置了主帐户并且您要发送的帐户具有“代表发送”或“发送为”权限，这应该可以工作：

Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer

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

'Uncomment the next 3 lines to enable Outlook 2013/2016/2019/365 Reading Pane Reply
'Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
    'Call SetFromAddress(objItem)
'End Sub

Public Sub SetFromAddress(oMail As Outlook.MailItem)
    ' Set your preferred default From address below.
    ' Exchange permissions determine if it is actually stamped
    ' as "Sent On Behalf Of" or "Sent As".
    ' The address is not properly updated for the InlineResponse
    ' feature in Outlook 2013/2016/365. This is only a visual bug.
    If oMail.SendUsingAccount = "primary@domain" Then
        oMail.SentOnBehalfOfName = "delegate@domain"
    End If
End Sub