Solved

BCC automatically on one of two accounts

Posted on 2008-10-22
6
359 Views
Last Modified: 2012-05-05
I would like to have emails sent from a particular account sent with a BCC automatically.

I've found the attached code snippet for automatically populating the BCC field when an email is sent, placed it in 'ThisOutlookSession' of the VBA editor but it doesn't seem to work. I've gone in and placed a breakpoint but it never seems to fire.

In addition, I would like to have the BCC populate only on one of my two email accounts. How can I do that?
the second piece of code below is supposed to do that but it doesn't seem to fire either.....

HELP!


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
    On Error Resume Next
 
    ' #### USER OPTIONS ####
    ' address for Bcc -- must be SMTP address or resolvable
    ' to a name in the address book
    strBcc = "sburrows@hisconsulting.net"
 
    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
 
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objCDO As MAPI.Session, _
        objMsg As MAPI.message, _
        colFields As MAPI.Fields, _
        objField As MAPI.Field, _
        strAccountName As String
    Item.Save
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    Set objMsg = objCDO.GetMessage(Item.EntryID, Item.Parent.StoreID)
    Set colFields = objMsg.Fields
    On Error Resume Next
    strAccountName = colFields.Item(&H8014001E)
    If Err.Number = -2147221233 Then
        strAccountName = "Default Account"
    End If
    On Error GoTo 0
    Select Case strAccountName
        Case "pop1.company.com"
            Debug.Print "Account1"
        Case "pop2.company.com"
            Debug.Print "Account2"
        Case "Default Account"
            Debug.Print "Default"
    End Select
    Set objMsg = Nothing
    Set objField = Nothing
    Set colFields = Nothing
    objCDO.Logoff
    Set objCDO = Nothing
    Cancel = True
End Sub

Open in new window

0
Comment
Question by:scbdpm
  • 3
  • 3
6 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 22777439
Hi, scbdpm.

First, there are two subroutines with the same name.  That's illegal.  Outlook won't run either one.  Remove one or the other.  Also, make sure that macros are enabled in Outlook.
0
 

Author Comment

by:scbdpm
ID: 22778085
that's not the case.
 
I've tried each seaprately and neither one fires!
0
 
LVL 76

Expert Comment

by:David Lee
ID: 22778166
Ok, didn't know that.  They were posted together, so it looked to me as if they were both in use.  Have you verified that macros are enabled in Outlook?
0
Free learning courses: Active Directory Deep Dive

Get a firm grasp on your IT environment when you learn Active Directory best practices with Veeam! Watch all, or choose any amount, of this three-part webinar series to improve your skills. From the basics to virtualization and backup, we got you covered.

 

Author Comment

by:scbdpm
ID: 22778190
Have 2007. Am new to it.... is this done in Trust Center?
Not sure, could you provide guidance.....
0
 

Author Comment

by:scbdpm
ID: 22779392
ok, so I got the macros working.
 
Now, I am not getting the correct account. I am always getting 'Default Account"....
can you help?
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 22782348
On closer look neither of those macros are for Outlook 2007.  Use this version instead.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olkRecipient As Outlook.Recipient
    If Item.Class = olMail Then
        'Change the address on the following line'
        If Item.SendUsingAccount.DisplayName = "myaccount@mycompany.com" Then
            'Change the address on the following line'
            Set olkRecipient = Item.Recipients.Add("someone@company.com")
            olkRecipient.Type = olBCC
            Item.Recipients.ResolveAll
            Item.Save
        End If
    End If
End Sub

Open in new window

0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
In this step by step procedure, you will come to know the details of creating an Outlook meeting in 2007, 2010, 2013 & 2016.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

856 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question