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
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 need a macro which can match domain name of the email ids in TO and CC from a list of emails(preferably from excel) and if any of the email address does not match, it should throw a pop-up asking if the user wants to continue and if yes then the mail should be sent as it is and a email id should be added in BCC.
Please find the sample code, it works but I also want to compare the domain name as a sub-string in the subject.
Ex: The if the subject line is "ABC Report- Company1- Jan-2 and it is sent to a1#company1.com, a2#compay2.com then it should prompt that the a2#company2.com is an unauthorized email and ask if still the user want to proceed, if Yes it should copy admin#mycompany.com in BCC and delay the mail by 5mins.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt As String
Dim strMsg As String
Dim Address As String
Dim lLen
Dim strSubject As String
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
strSubject = Item.Subject
If strSubject Like "*ACB Report*" Or strSubject Like "*XYZ Report*" Then
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
Select Case Right(Address, lLen)
Case "cdolive.com", "gmail.com", "slipstick.com", "outlookmvp.com"
Case Else ' remove case else line to be warned when sending to the addresses
strMsg = strMsg & " " & Address & vbNewLine
End Select
Next
If strMsg <> "" Then
prompt = "This email will be sent outside of the company to:" & vbNewLine & strMsg & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End If
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt As String
Dim strMsg As String
Dim Address As String
Dim lLen
Dim strSubject As String
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
strSubject = Item.subject
If strSubject Like "*ABC Report*" Or strSubject Like "*XYZ Report*" Then
Set recips = Item.Recipients
For Each recip In recips
If recip.Type <> olBCC Then
Set pa = recip.PropertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
'rlen = Len(Address) - InStrRev(Address, "#")
'If strSubject Like "*rlen*" Then
lLen = Len(Address) - InStrRev(Address, "#")
'Select Case Left(Address, rlen)
'Case "acceture", "slipstick"
'Case Else
'strMsg = strMsg & " " & Address & vbNewLine
'End Select
'Next
Dim SendMail As Boolean
Select Case Right(Address, lLen)
Case "cdolive.com", "slipstick.com", "outlookmvp.com", "accenture.com"
' "select case" is doing nothing in this case
SendMail = True
Case Else ' remove case else line to be warned when sending to the addresses
strMsg = strMsg & " " & Address & vbNewLine
End Select
If strMsg <> "" And Not SubjectContainsEmailDomain(strSubject, Address) Then
prompt = "The system has detected that you are sending this email to some unauthorized user:" & vbNewLine & strMsg & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
Else
' add BCC
Dim objRecip As Recipient
Set objRecip = Item.Recipients.Add("myid#gmail.com")
objRecip.Type = olBCC
objRecip.Resolve
'MailItem.DeferredDeliveryTime = DateAdd("n", 90, Now)
End If
End If
' Cancel if not in "cdolive.com", "slipstick.com", "outlookmvp.com"
If Not SendMail Then Cancel = True
MsgBox "The entered email address(s) are not aliged to you" & vbNewLine & "Please add the domain name in the code"
'End If
'End If
End If
Next
Last:
End If
End If
End If
End Sub
Function GetDomain(emailAddress As String) As String
Dim arr As Variant
arr = Split(emailAddress, "#")
GetDomain = Left(arr(1), InStrRev(arr(1), ".") - 1)
End Function
Function SubjectContainsEmailDomain(subject As String, email As String) As Boolean
Dim domain As String
domain = GetDomain(email)
Dim index As Integer
SubjectContainsEmailDomain = InStr(LCase(subject), LCase(domain))
End Function
The next to last part of an email address is the Second Level Domain (2LD).
This seems to be finding Recipient2LD that is different from the Subject Company.
The Subject seems to be free form typing by users, and I have no idea how to parse the SubjectCompany out of the Subject line, but if you could then this could be added after EndSelect and before Next.
Dim RecipDomainParts() As String
RecipDomainParts = Split(Right(Address, lLen), ".")
Dim Recip2LD As String ' Recipient Second Level Domain
Recip2LD = DomainParts(UBound(DomainParts) - 1)
' I have no idea how to parse the SubjectCompany out of the Subject line
If Recip2LD <> SubjectCompany Then
strMsg = strMsg & " " & Address & vbNewLine
End If
->>added 9/2/18
you need to decide yourself the general outline of your process: whether to possibly have an error message for each Recipient for each problem (List or Subject) or to combine into one message for a Recipient, while doing each Recipient, or append each msg into one message at the end of all Recipients... Then follow your outline. Work at refining the outline first, then write the code to match.
It may be good to make sub for "Recip_in_List" and make a sub for "RecipDomain_in_Subject" after you revise the outline.
BCC probably should not be skipped, as user might try to put an email there.
Your xyz#qwerty.com should be in the List.
variable SendMail cannot be set to True because it would wipe out False that had been set on prior Recipient. By doing Exit Sub when vbNo you eliminate this boolean.
Set Delay = 0min
For each Recip
If Recip not in List
Popup to user
If vbNo then Cancel=True and exit without send
Else add BCC of xyz#qwerty.com if not there
endif
endif
If RecipDomain not in Subject
Popup to user
If vbNo then Cancel=True and exit without send
Else add BCC of admin#qwerty.com if not there
set Delay = 5min
endif
endif
Next Recip
SEND with Delay
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
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`