Автоматическая почтовая рассылка с отправителем

Question

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

поэтому каждый раз, когда я пришлю письмо от x@domaine.com, автоматически отправит письмо BCC от x@domaine.com, то же самое, если я отправлю с y@domaine1.com, отправит BCC на y @ domaine1. ком

я попробовал этот код, но он не работает, и в моем макросе безопасности все включено

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
Dim objRecip As Recipient 
Dim strMsg As String 
Dim res As Integer 
Dim strBcc As String 
Dim myOlApp As Outlook.Application 
Dim myOlMsg As Outlook.MailItem 

On Error Resume Next 

Set myOlApp = CreateObject("Outlook.Application") 
Set myMsg = myOlApp.ActiveInspector.CurrentItem 

strBcc = myMsg.SenderEmailAddress 

Set objRecip = Item.Recipients.Add(strBcc) 
objRecip.Type = olBCC 
If Not objRecip.Resolve Then 
strMsg = "Could not resolve the Bcc recipient. " & _ 
"Do you want still to send the message?" 
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _ 
"Could Not Resolve Bcc Recipient") 
If res = vbNo Then 
    Cancel = True 
End If 
End If 
Set objRecip = Nothing 

End Sub 

Answer 1

немного запутался о вашем вопросе, Если у вас есть несколько учетных записей настроить на вашем мировоззрении, то это должно дать вам CurrenUser. для получения имени текущего пользователя.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
    Dim olNamespace As Outlook.NameSpace 
    Dim olRec As Outlook.Recipient 
    Dim Address$ 

    Set olNamespace = Application.GetNamespace("MAPI") 

    Address = olNamespace.CurrentUser 

    Set olRec = Item.Recipients.Add(Address) 
    olRec.Type = olBCC 
    olRec.Resolve 
End Sub 

Answer 2

Пункт отправки передается код в качестве параметра, не используйте myOlApp.ActiveInspector.CurrentItem. Инспектор может быть уже закрыт или сообщение может быть создано как встроенный ответ.

Answer 3

Попробуйте SendUsingAccount

См https://msdn.microsoft.com/en-us/library/office/ff869311.aspx

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
Dim objRecip As Recipient 
Dim strMsg As String 
Dim res As vbMsgBoxResult 
Dim strBcc As String 

'Dim myOlApp As Outlook.Application 
'Dim myOlMsg As Outlook.MailItem 

' hides errors, this is not a good thing 
'On Error Resume Next 

' You can use the already running instance of Outlook 
'Set myOlApp = CreateObject("Outlook.Application") 

' CurrentItem is Item: ByVal Item As Object 
'Set myMsg = myOlApp.ActiveInspector.CurrentItem 

'strBcc = myMsg.SenderEmailAddress 
strBcc = Item.SendUsingAccount 

Set objRecip = Item.Recipients.Add(strBcc) 
objRecip.Type = olBCC 

If Not objRecip.Resolve Then 
    strMsg = "Could not resolve the Bcc recipient. " & _ 
    "Do you want still to send the message?" 
    res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _ 
    "Could Not Resolve Bcc Recipient") 
    If res = vbNo Then 
     Cancel = True 
    End If 
End If 

Set objRecip = Nothing 

End Sub