自动填充 CC 字段

Question

我正在寻找一种方法，在执行任何电子邮件操作（新电子邮件、回复、全部回复、转发等）时，CC 字段在实际发送电子邮件之前填充电子邮件“example@domain.com” （Outlook 规则在发送电子邮件后添加抄送，所以这不起作用）

在发送电子邮件之前添加抄送的原因是，如果电子邮件是机密的，用户可以删除“examlle@domain.com”

非常感谢任何帮助，因为我已经搜索了几个小时！

Answer 1

我不确定您的 VBA 经验水平，但这是在 Stack Overflow 上提出的一个问题，其中包含您想要做什么的所有基础。

Add CC

唯一需要更改的是添加其他操作（当前代码仅使用 .forward）：新电子邮件、回复和全部回复。

请务必使用 .Display 而不是 .Send，这样会显示电子邮件，然后发件人可以在发送电子邮件之前编辑他想要的内容。

[编辑]

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem

'to start the macro when outlook starts  
Private Sub Application_Startup()
   Set oExpl = Application.ActiveExplorer
   bDiscardEvents = False
End Sub

Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.Item(1)
End Sub

'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Reply
 afterReply
End Sub

'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Forward

 afterReply
End Sub

'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.ReplyAll

 afterReply
End Sub

Private Sub afterReply()
    oResponse.Display

 ' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
    oResponse.CC = "example@domain.com"
End Sub

这是我在我的环境中整理和测试的代码。只需将其粘贴到 ThisOutlookSession 下的 VBA 编辑器中即可。要启动它，请在 Application_Startup Sub 内单击并点击播放。它深受我不久前发现的另一个代码的启发。但是我没有来源。每次启动 Outlook 时，它都会自动启动。

Answer 2

@LaZoR_Bear

根据我前段时间在网上找到的一些代码来解决这个目的（自动更改所有新电子邮件、回复、全部回复、转发等的发件人地址），我终于弄清楚了将其设置为 CC on new 的语法电子邮件（但您的代码仍然是必需的，因此再次感谢您）。

仅用于更改发件人地址的代码：

'=================================================================
'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/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

'The next 3 lines to enable Outlook 2013/2016/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 = "example@doman.com"
End Sub

然后将您的代码添加到它上面（加上 oMail.CC = "example@domain.com" 到上面的代码）看起来像这样：

Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer

Private Sub Application_Startup()
    Initialize_handler
    Set oExpl = Application.ActiveExplorer
    bDiscardEvents = False
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

'The next 3 lines to enable Outlook 2013/2016/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 = "example@domain.com"
    oMail.CC = "example@domain.com"
End Sub

Private Sub oExpl_SelectionChange()
   On Error Resume Next
   Set oItem = oExpl.Selection.item(1)
End Sub

'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Reply
 afterReply
End Sub

'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.Forward

 afterReply
End Sub

'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
   Cancel = True
   bDiscardEvents = True

Set oResponse = oItem.ReplyAll

 afterReply
End Sub

Private Sub afterReply()
    oResponse.Display

 ' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
    oResponse.CC = "example@domain.com"
End Sub