Автозаполнение поля CC

Question

Я ищу способ, которым при выполнении любого действия по электронной почте (новое письмо, ответ, ответить всем, переслать и т. Д.) Поле CC заполняется электронным письмом "example@domain.com" перед фактической отправкой письма(правила Outlook добавляют CC после отправки электронного письма, поэтому это не работает)

Причина добавления CC перед отправкой электронного сообщения состоит в том, что пользователь может удалить «examlle@domain.com»если электронная почта конфиденциальна

Любая помощь очень ценится, так как я искал несколько часов!

Answer 1

@ 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

Answer 2

Я не уверен в вашем уровне опыта работы с VBA, но вот вопрос, который был задан в отношении переполнения стека, который содержит всю основу того, что вы хотите сделать.

Добавить 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

Вот код, который я собрал и протестировал в своей среде. Просто вставьте его в свой редактор VBA под ThisOutlookSession. Чтобы запустить его, щелкните внутри подпрограммы Application_Startup и нажмите кнопку воспроизведения. Он был сильно вдохновлен другим кодом, который я нашел некоторое время назад. У меня нет источника однако. При каждом запуске Outlook он должен запускаться автоматически.