I have little VBA experience so I found a few post that were kinda like what I want but I can't seem to make them work.
I would like a to add an email address to outlook as a Bcc and send it.
It goes under thisOutlookSession
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olRecip As Recipient
Dim olMsg As String
Dim res As Integer
Dim olBcc As String
On Error Resume Next
'// set email address here
olBcc = "Address#domain.com"
Set olRecip = Item.Recipients.Add(olBcc)
olRecip.Type = olBcc
If Not olRecip.Resolve Then
olMsg = "Could not resolve Bcc recipient. " & _
"Do you still want to send?"
res = MsgBox(olMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set olRecip = Nothing
End Sub
Related
I'm trying to program Outlook VBA to:
automatically bcc one email, and
check if a second email address is a recipient (including cc and bcc) and if it is, don't do anything but if it is not, then add the second email as a cc.
The code below adds the second email address as a cc even if it already is a cc causing the second email address to be listed twice in the cc line. How can I fix this code? Below is the code. Thank you!
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 strcc As String
Dim pkemailcounter As Integer
On Error Resume Next
pkemailcounter = 0
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address
' or resolvable to a name in the address book
strBcc = "email1#exampleemail.com"
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc")
If res = vbNo Then
Cancel = True
End If
End If
For Each Recipient In Item.Recipients
If (Recipient.Address = "email2#exampleemail.com") Then
pkemailcounter = pkemailcounter + 1
Exit For
End If
Next
If pkemailcounter = 0 Then
strcc = "email2#exampleemail.com"
Set objRecip = Item.Recipients.Add(strcc)
objRecip.Type = olCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve cc")
If res = vbNo Then
Cancel = True
End If
End If
End If
Set objRecip = Nothing
End Sub
If you re-structure your code to break it up a bit it might be easier to figure out where the problem lies:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address
' or resolvable to a name in the address book
Const strBcc As String = "email1#exampleemail.com"
Const strCc As String = "email2#exampleemail.com"
Dim objRecip As Recipient
If Not TypeOf Item Is MailItem Then Exit Sub 'only handle emails
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not CheckResolve(objRecip) Then Cancel = True
If HasRecipient(Item, strCc) Then Exit Sub
Set objRecip = Item.Recipients.Add(strCc)
objRecip.Type = olCC
If Not CheckResolve(objRecip) Then Cancel = True
End Sub
'does a mail `itm` have `recip` as a recipient?
Function HasRecipient(itm As MailItem, recip As String) As Boolean
Dim rcp As Recipient
For Each rcp In itm.Recipients
If UCase(recip) = UCase(rcp.Address) Then
HasRecipient = True
Exit Function
End If
Next rcp
End Function
'Return True if recipient can be resolved, or if it can't
' but the user elects to send anyway
Function CheckResolve(objRecip As Recipient) As Boolean
Dim rType As String, strMsg As String
rType = IIf(objRecip.Type = olCC, "CC", "BCC")
If Not objRecip.Resolve Then
strMsg = "Could not resolve the " & rType & " recipient. " & _
"Do you still want to send the message?"
CheckResolve = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve " & rType) = vbYes
Else
CheckResolve = True
End If
End Function
I want to automatically BCC two email addresses.
I found this code from groovypost.com but it can only BCC one address.
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 = "SomeEmailAddress#domain.com"
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
End If
Set objRecip = Nothing
The below adjustments should allow you to enter as many addresses as you want, provided that you split them with a semicolon ;. It creates an array of addresses and repeats the process for as many email iterations exist.
Side note. I did lookup what I presume is this article you mentioned. I noticed that it made the strong claim that this code would not store the BCC record in the sender's sent box. I don't believe this to be true. Thus I'm not sure what the real advantage is to using this VBA code versus just setting up a message rule.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'make sure to separate with ;
Const strBcc As String = "first_email_Address#yopmail.com;second_email_Address#yopmail.com"
Dim objRecip As Recipient, strMsg As String, res As Long, i As Long
'On Error Resume Next
Dim theAddresses() As String
theAddresses = Split(strBcc, ";", -1)
For i = LBound(theAddresses) To UBound(theAddresses)
Set objRecip = Item.Recipients.Add(theAddresses(i))
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
End If
End If
Next i
Set objRecip = Nothing
End Sub
I want to apply HTML when a user prepares email with a default template.
I got some basic code online:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
If InStr(LCase(Item.To), "xxx#gmail.com") Then
prompt$ = "Are You Sure want to send this email to " & Item.To& " ?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
Dim objOutlookMsg As Outlook.MailItem
Set objOutlookMsg = Outlook.Application.CreateItem(olMailItem)
objOutlookMsg.HTMLBody = "<html><body><strong>HELLO OUTLOOK</strong></body></html>"
objOutlookMsg.Display
End If
End If
End Sub
When I send, a new message window opens.
I want that HTML to present in the same window, not a new window.
The Item.To Property Returns String list of display names, what you need it Recipient.Address Property which will Return a String representing the email address of the Recipient.
Also check If Item.Class <> olMail if not then Exit Sub
Full Example
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Item.Class <> olMail Then Exit Sub
Dim Rcpt As Recipient
Dim Prompt As String
Prompt = "Are You Sure want to send this email to " & Item.To & " ?"
For Each Rcpt In Item.Recipients
If InStr(1, Rcpt.AddressEntry, "TEST#gmail.com", vbTextCompare) Then
If MsgBox(Prompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, _
"Check Address ") = vbNo Then
Cancel = True
Exit Sub
End If
Item.HTMLBody = "<html><body><strong>HELLO OUTLOOK</strong></body></html>" _
& Item.HTMLBody
End If
Next
End Sub
Updated per comments
Simply remove if MsgBox end if block of code
Example
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Item.Class <> olMail Then Exit Sub
Dim Rcpt As Recipient
For Each Rcpt In Item.Recipients
If InStr(1, Rcpt.AddressEntry, "TEST#gmail.com", vbTextCompare) Then
Item.HTMLBody = "<html><body><strong>HELLO OUTLOOK</strong></body></html>" _
& Item.HTMLBody
End If
Next
End Sub
If you want to modify the HTML body of the message begin sent (it is passed as the Item parameter to your event handler), why are you creating a new message instead of modifying the existing message? Set HTMLBody property on the Item object.
I found a block of code that will let me BCC automatically every email I send.
What I want to do is: When received with something specific in the subject line, the email is auto-forwarded with "email#email.com" in the BCC field and no one in the To line.
Public Sub BCC(Item As Outlook.MailItem)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim BCC_ADDR As String
On Error Resume Next
BCC_ADDR = "email#email.com"
Set objRecip = Item.Recipients.Add(BCC_ADDR)
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
You need to use the Forward method which executes the Forward action for an item and returns the resulting copy as a MailItem object. Then you can use the Send method to submit the item for further processing. For example:
`Public Sub BCC(Item As Outlook.MailItem)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim BCC_ADDR As String
Dim forward as MailItem
On Error Resume Next
BCC_ADDR = "email#email.com"
Set forward = Item.Forward
Set objRecip = forward.Recipients.Add(BCC_ADDR)
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
Else
foward.Send
End If
Set objRecip = Nothing
End Sub`
Program: Outlook 2010
OS: Win8
VBA Skill: Novice
Notes:
This works perfectly if I remove the following option
Private Sub Application Item_Send
'[3]
If Item.SendUsingAccount = "Account Name here" Then
If I do not remove it (keeping my BCC exception) the email on startup Private Sub Application _Startup runs however it BCCs only the email listed in item [3] = "special#domain.com".
When part [3] is removed both run as coded.
1) 1 email on startup, BCCing all accounts listed to check the Macro,
2) During the day all emails sent have the correct BCC attached, all the exceptions work as coded.
It seems that there is something that I have missed which stops every mail code from running in to the startup mail code.
I have tried a number of changes, including added IF & else functions.
Both are run in my This Outlook Session
Code:
Private Sub Application_Startup()
'Creates a new e-mail item and modifies its properties on startup
'Testing email settings, checking Macros enabled
Dim olApp As Outlook.Application
Dim objMail As Outlook.mailItem
Set olApp = Outlook.Application
'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = "Login Test" & " | " & Format(Now, "YYYYMMDD - HH:mm:ss")
.Body = "Testing the BCC" & " | " & Format(Now, "YYYYMMDD")
.To = "1.alerts#domain.com; device#domain.com"
.Recipients.ResolveAll
.Send
End With
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'source: http://www.outlookcode.com/article.aspx?id=72
'source: http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/ (exceptions) [2]
'source: http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
'On Error Resume Next
'[2]
If Item.Categories = "zBCC no" Then
Exit Sub
Else
If Item.To = "personal#domain.com" Then
Exit Sub
Else
If InStr(1, Item.Body, "zebra") Then
Exit Sub
Else
If Item.To = "1#domain.com" Or Item.To = "2#domain.com" Then
strBcc = "3#domain.com"
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
Exit Sub
Else
'[3]
If Item.SendUsingAccount = "Account Name here" Then
strBcc = "special#domain.com"
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
Exit Sub
Else
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable to a name in the address book
strBcc = "1#domain.com"
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
strBcc = "2#domain.com"
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
strBcc = "3#domain.com"
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
End If
End If
End If
End If
End If
Set objRecip = Nothing
End Sub
My possibly false impression is, at the time you wrote this, you did not know how to debug. This may have been helpful http://www.cpearson.com/Excel/DebuggingVBA.aspx
Here is a simplified untested version. I removed all the Else statements.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'source: http://www.outlookcode.com/article.aspx?id=72
'source: http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/ (exceptions) [2]
'source: http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
'[2]
If Item.Categories = "zBCC no" Then Exit Sub
If Item.To = "personal#domain.com" Then Exit Sub
If InStr(1, Item.Body, "zebra") Then Exit Sub
If Item.To = "1#domain.com" Or Item.To = "2#domain.com" Then
strBcc = "3#domain.com"
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
GoTo ExitRoutine
End If
'[3]
If Item.SendUsingAccount = "Account Name here" Then
strBcc = "special#domain.com"
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
GoTo ExitRoutine
End If
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable to a name in the address book
strBcc = "1#domain.com"
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
GoTo ExitRoutine
End If
End If
strBcc = "2#domain.com"
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
GoTo ExitRoutine
End If
End If
strBcc = "3#domain.com"
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
ExitRoutine:
Set objRecip = Nothing
End Sub
When you debug you will note Item.SendUsingAccount is always blank.
You can try setting SendUsingAccount Use the mail account you want in your mail macro but it is a little trickier than SentOnBehalfOfName (From). Note manually setting From will not update SentOnBehalfOfName.
You can see how it works with this.
Sub SetSentOnBehalf()
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(0)
objMsg.SentOnBehalfOfName = "bingo#bongo.com"
objMsg.Display
MsgBox " SentOnBehalfOfName in the From: " & objMsg.SentOnBehalfOfName
Set objMsg = Nothing
End Sub