I have a script that runs under Application_ItemSend in Outlook 2010.
It checks the recipient address and if it isn't one of our own domains it will prompt a confirmation message asking if you want to send the email externally.
The complete code for this can be found here:
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
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain1.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain2.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain3.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain4.com.au") = 0 Then
strMsg = strMsg & " " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
End If
Next
For Each recip In recips
Set pa = recip.PropertyAccessor
If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain1.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain2.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain3.com.au") = 0 And InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "#ourdomain4.com.au") = 0 Then
prompt = "This email will be sent outside of ourdomains.com.au to:" & vbNewLine & strMsg & "Do you want to proceed?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
Exit Sub
Else
Exit Sub
End If
End If
Next
End Sub
This works great, except it has started throwing an error when sending to some distribution lists. Hitting 'end' to the error pop-up the email is still sent.
"The Property "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
is unknown or cannot be found.
From what I have google'd, this is because there isn't always a MIME property present so it cannot always be resolved to an SMTP address.
How can I go about changing this so it will not throw the error?
That property may or may not work depending on whether or not the recipient is an Exchange user within your Exchange organization, and whether or not the cached mode is enabled with Exchange.
PR_SMTP_ADDRESS is not available in cached mode. You would use PR_EMS_AB_PROXY_ADDRESSES in cached mode, which is a PT_MV_STRING8 or PT_MV_UNICODE (string array) property.
Finally, you may find the HowTo: Convert Exchange-based email address into SMTP email address article helpful.
PR_SMTP_ADDRESS is not guaranteed to be present. Also if you send to an SMTP recipient, the property will not be present, but PR_EMAIL_ADDRESSS property (exposed by the Recipient.Address property) will contain a regular SMTP address.
Check if PR_ADDRTYPE is "SMTP", and read PR_EMAIL_ADDRESSS. Otherwise try (and handle the error appropriately) to read the PR_SMTP_ADDRESS property.
Related
We've got multiple users using an existing mailbox on Outlook. Everyone who sends from the mailbox recieves the "sent items" in their own personal mailbox. I've looked in rules and cannot find anything to have the sent items appear in the group mailbox's sent items instead.
I've got the following code, but cannot work out why it's not running.
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
strBcc = "<mailboxname>"
If Item.SendUsingAccount = "<mailboxname>" Then
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
'Set variable objRecip (recipient) = Item.Recipients.Add (strBcc)
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
End If
Set objRecip = Nothing
End Sub
To have the mail sent from the mailbox account you need to do the following:
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
...
End With
Where oMailItem and oOutlook refer to your relevant objects and iAccount is the index number of the mailbox you want to use. In my case I have two mailboxes available to send from, my personal one and the group one. My personal account is first (index 1) and the group mailbox is second (index 2).
Mail Items I send using this code always move to the Sent Items folder in the group mailbox rather than my personal one.
I am looking to create a rule that will conditionally add a BCC recipient depending on the domain name of the To/CC recipients. I have already identified this question as something similar but it doesn't seem to have been resolved.
The starting code is as below:
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 = "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
Set objRecip = Nothing
End Sub
In pseudo-code I am looking to add the following conditionals to the strBCC string:
If ToCCRecipientDomain = "#example1.co.uk"
Then strBCC = "email1#trello.com"
ElseIf ToCCRecipientDomain ="#example2.co.uk"
Then strBCC = "email2#trello.com"
ElseIf ToCCRecipientDomain ="#example3.co.uk"
Then strBCC = "email3#trello.com"
Else
Then Cancel = True
End If
For those interested in the application/reason for this, I am looking to create a list of emails sent to a client on a Trello Board for the particular project, which will depend on the email address being sent to.
I think I am close with this as below, simply adding additional If & EndIf lines when additional conditions are required.
If InStr(Item.Recipients.Address, "#example1.co.uk") Then
strBcc = "email1#trello.com"
If InStr(Item.Recipients.Address, "#example2.co.uk") Then
strBcc = "email2#trello.com"
Else
Cancel = True
End If
End If
I have a macro coded to a rule that autoforwards all incoming and sent emails to a private email address in the BCC field (any auto BCC rule is disabled at the server level.) With the help of the board here, the macro works flawlessly, and for all intents and purposes is invisible.
However, if you open the SENT message in the SENT FOLDER, the BCC field is visible to all for the world to see. I have learned this is a "feature" in Outlook, apparently since 2003.
Is there a way to suppress the visibility of the BCC field when viewing the SENT email?
Or is there a way one can set the display options of an individual folder NOT to display a BCC - EVER?
Thank you for any assistance.
My code:
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 answer
Dim oAtt
Dim strProc1 As String
On Error GoTo Application_ItemSend_Error
strBcc = "myprivateemail#gmail.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
Set objRecip = Nothing
On Error GoTo 0
Exit Sub
Application_ItemSend_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") " & "Error on
Line " & Erl & " in procedure Application_ItemSend of VBA Document
ThisOutlookSession"
End Sub
If you want to remove BCC recipients in the Sent Items folder, listen for the Items.ItemAdd event on the Sent Items folder, loop through all recipients in the MailItem.Recipients collection and delete recipients with Recipient.Type = olBCC.
"the BCC field is visible to all for the world to see"
Well, if anyone in the world can view your own sent folder, then this is the case. Otherwise the BCC field is not part of the email, recipients do not receive it. The goal of the feature is to have the ability to recall your own BCC messages, so you do not forget that you have sent them.
Try the following...
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olRec As Outlook.Recipient
Dim Address$
Address = "Om3r#blala.com"
Set olRec = Item.Recipients.Add(Address)
olRec.Type = olBCC
olRec.Resolve
End Sub
Newbie poster with Outlook VBA. Intermediate Excel VBA coder.
I have a VBA routine that autoforwards all incoming email to a Gmail account. It is not all my code, (modified from a blog post) but it works. I need to keep a copy of all my email received in all my accounts so I can consolidate them into one main one. In the Outlook 2010 Exchange account, all the forwarded mail gets saved in the SENT folder as a copy.
Is it possible to delete the autoforwarded copy in the SENT folder, without deleting all SENT emails? I need to keep the emails I actually respond to.
I would not have a problem using conversation mode in the INBOX, to store the replied to emails. but as it now stands, everything is duplicated due to the bcc copy in the SENT folder when I toggle Conversation mode for the INBOX.
Thanks in advance for any assistance.
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 = "bcc.hwb#gmail.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
Set objRecip = Nothing
End Sub
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim myItem As MailItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
'MsgBox (varEntryIDs(i))
Set myItem = objItem.Forward
myItem.Recipients.Add "bcc.hwb#gmail.com"
myItem.Send
'myItem.Delete
Set myItem = Nothing
Next
End Sub
See MailItem.DeleteAfterSubmit Property (Outlook)
myItem.DeleteAfterSubmit = True
Goal: Silently (no dialog box) delete one or more email addresses from recipient collection on ItemSend.
Seems I need to remove recipients by name or index. How do I obtain the index of the email or match it to an SMTP address.
I found some code at the bottom of this message that obtains the SMTP address, but can't find code that I need to start with which is to simply remove a recipient. Then looping it all and matching to an SMTP address seems daunting.
What I'd like to happen
Sub DoNotEmailTheseAddresses()
Dim Msg As Outlook.MailItem
Set Msg = Outlook.CreateItem(olMailItem)
With Msg
run through IndexNumber to find recipients in To:, CC:, and BCC: collection
If RecipientIndexNumber.SMTPaddress = "somebody#adomain.com"
RecipientIndexNumber.SMTPaddress.Remove
If RecipientIndexNumber.SMTPaddress = "somebodyELSEtoo#adomain.com"
RecipientIndexNumber.SMTPaddress.Remove
End With
End Sub
....and off goes the email with somebody#adomain.com and somebodyELSEtoo#adomain.com handily removed.
Getting the corresponding SMTP address code is on MSDN site. http://msdn.microsoft.com/en-us/library/office/ff866259(v=office.15).aspx
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.name & " SMTP=" _
& pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
you are not that far away....
For each mail-address you want to remove, you have to go through all recipients and check if they have this mail-address. If yes, remove them. therefor I have put this into a separate function, which you can call for each mail-address you want to remove.
Public Sub newItem_Open(Cancel As Boolean)
Call removerecipi(newItem, "somebody#adomain.com")
End Sub
Function removerecipi(mailitem As Outlook.mailitem, rec_mail As String)
Dim i As Long
restart:
For i = 1 To mailitem.Recipients.Count
If i > mailitem.Recipients.Count Then GoTo restart
If mailitem.Recipients(i).SmtpAddress = rec_mail Then mailitem.Recipients.Remove i
Next i
End Function
why is the restart necessary: after removing one recipient, the mailItem.Recipients.Count needs to be reset. There are also other Solutions, however this one works fine.