Automatic bcc to sender mail

Question

I want to write a code in VBA outlook 2016 to send a BCC in every mail I send, I have many senders mail , many emails on one outlook account.

so every time i will send an email from x@domaine.com , automatically sendS a BCC email from x@domaine.com , same if I send from y@domaine1.com will send a BCC to y@domaine1.com

i tried this code but it doesn't work , and in my security macro all is enabled

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

On Error Resume Next hides errors. Remove it and you can debug. — niton, Jan 14 '16 at 10:58

0m3r · Answer 1 · 2016-01-14T09:18:09.533

Little Confused about your Question, Assuming you have multiple accounts set up on your outlook then this should give you CurrenUser. property to obtain the name of the currently logged-on user.

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

score 0 · Answer 2 · edited Jan 15 '16 at 12:50

0

The item being sent is passed to your code as a parameter, do not use myOlApp.ActiveInspector.CurrentItem. The inspector could be already closed or the message might have been created as an inline response.

edited Jan 15 '16 at 12:50

Vadim Martynov

8,602
5
31
43

answered Jan 14 '16 at 13:53

Dmitry Streblechenko

62,942
4
53
78

score 0 · Answer 3 · answered Jan 14 '16 at 16:48

Try SendUsingAccount

See 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

Automatic bcc to sender mail

3 Answers3