Question

我正在寻找一种方法，在执行任何电子邮件操作（新电子邮件，回复，全部回复，转发等）时，在实际发送电子邮件之前，抄送字段将填充电子邮件“ 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的语法电子邮件（但是仍然需要您的代码，因此再次感谢您）。

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

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

自动填充抄送字段

2 个答案: