Friday, August 19, 2011 9:09 AM
I hope this helps….i am not a programmer in any form, but have been able to paste this together from several different sites. It works for me very well as I have several accounts setup in my Outlook 2010. Enjoy….good luck with using it.
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 objMsg As Outlook.MailItem
On Error Resume Next
' #### USER OPTIONS ####
'Select one of the below Options, remove the comment marks (') in front of the line
'Add text to the subject line when sending email
Set objMsg = Outlook.ActiveInspector.CurrentItem
'objMsg.Subject = "Test"
'objMsg.Subject = "Prepended text here - " & objMsg.Subject
'objMsg.Subject = objMsg.Subject & " - Appended text here"
' Address for Bcc -- must be SMTP address or resolvable
' Automatically selects the bcc address from the set "from" setting or
' to a select email address, your choose
strBcc = Item.SendUsingAccount
'strBcc = "SomeEmailAddress@domain.com"
' Option 1: Select if you wish to auto bcc from a select account in outlook automatically
'If Item.SendUsingAccount.SmtpAddress = " SomeEmailAddress@domain.com " Then
' Option 2: Select through notification meesage before sending the email if you wish to bcc the email
res = MsgBox("Would you like to receive a copy of this message (Bcc)?", vbYesNo + vbDefaultButton1, _
"BCC Message")
If res = vbNo Then
Cancel = False
Else
' Option 3: Select if you wish to sent on behalf:
' If Item.SentOnBehalfOfName = " SomeEmailAddress@domain.com " Then
Set objRecip = Item.Recipients.Add(strBcc)
' objRecip.Type = olBCC
objRecip.Type = Outlook.OlMailRecipientType.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
End If
Set objRecip = Nothing
End Sub
Good Luck...Cheers