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.
Related
I would like to display a message when sending to an external address. I used various stack overflow questions to create the VBA below. I use Office 365.
I found that a recipient which Outlook has assigned as an Outlook nickname does not resolve with an SMTP address.
Instead, the Recipients.Item(i).Address attribute resolves to something like
/o=NT5/ou=00000000000000000000000000000000/cn=122E0E7203FE4F448EC35B53EE8523A4
from which I am unable to extract the SMTP address. I need to check if this recipient is an external recipient.
I tried using the Recipients.Item(i).Name attribute (which just includes the first part of the address before the #) and attempted to resolve this using Session.CreateRecipient, but this fails. I also tried the same with the Recipients.Item(i).Address attribute.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xExternal As Integer
On Error Resume Next
xExternal = 0
If Item.Class <> olMail Then
Exit Sub
End If
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.Count To 1 Step -1
xRecipientAddress = xRecipients.Item(i).Address
If Left(xRecipientAddress, 1) <> "/" Then
'external address
If InStrRev(LCase(xRecipientAddress), "#email.domain") = 0 Then
'Any other SMTP Email domain
xExternal = 1
End If
Else
'catch for outlook nickname cache
If Left(xRecipientAddress, 6) = "/o=NT5" Then
'Code to get SMTP address from outlook nickname
End If
End If
Next
Note the #email.domain is updated in my code to our SMTP domain name
The code should assign xExternal = 1 if any external recipients are found in the recipients list. This should include any recipients Outlook has created an Outlook Nickname for and those with just SMTP addresses.
Use:
If Left(xRecipientAddress, 6) = "/o=NT5" Then
Debug.Print xRecipients.Item(i).AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Also, i don't think /0=NT5 will be consistent, so might want to change that.
I found a similar question but for c# Outlook : How to get email from Recipient field?
In this question there is also no correct answer.
Still, I tried some of the answers from this thread
recipient.AddressEntry.Address <= returns same thing as
recipient.Address what I used till yet and what gievs me following result:
"/o=POST/ou=Zuerich/cn=Recipients/cn=eicherr"
How can I get email adress of recipient?
I tried also .AddressEntry.GetContact().Email1Address and .AddressEntry.GetExchangeUser().Address this all not works for me.
Here is a MSDN docs explanes how to get email adress but I don't undestand how can I use it in my code Obtain the E-mail Address of a Recipient
my code:
Dim Msg As Outlook.MeetingItem
Set Msg = Item
Set recips = Msg.Recipients
Dim recip As Outlook.Recipient
For Each recip In recips
Dim email as String
email = CStr(recip.Address)
Debug.Print email
End For
If Recipient.AddressEntry.Type <> "EX", just use Recipient.Adddress. Otherwise use Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress
The documentation on the link I inserted finally helped me solve this problem.
For Each recip In recips
'Obtain the E-mail Address of a Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set pa = recip.PropertyAccessor
Dim email as String
email = CStr(pa.GetProperty(PR_SMTP_ADDRESS))
Debug.Print email
End For
I have code that runs when I send an email. It looks at the recipient address and the subject to see if it contains certain words and then pops up a message box to remind us to update our drawing revision control.
It works for internal email addresses and seems to work on some external email addresses. It doesn't like the email address I need to look for.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim hismail As String
Dim strSubject As String
strSubject = Item.Subject
Dim olObj As MailItem
Set olObj = Application.ActiveInspector.CurrentItem
hismail = olObj.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
Set olObj = Nothing
If hismail = "David#abclimited.net" And strSubject Like "*update*" Or strSubject Like "*revision*" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
End If
End Sub
I have changed the address in this post but it is the same format and length.
After a little bit of digging I found a solution that should get you pointed in the right direction. This is based off of the suspicion that your problem is due to your target user not being available within the Exchange server of your organization. This solution should solve the issue, but if it doesn't it will at least give you an idea of where to look next.
First, I took the code example from this MSDN article (https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/obtain-the-e-mail-address-of-a-recipient) and modified it so that it returns an array of Address Users and their emails:
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
Dim Recipients As Outlook.Recipients
Set Recipients = MailItem.Recipients
Dim Addresses As Variant
ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)
Dim Accessor As Outlook.PropertyAccessor
Dim Recipient As Outlook.Recipient
For Each Recipient In Recipients
Set Accessor = Recipient.PropertyAccessor
Dim i As Long
Addresses(i, 0) = Recipient.Name
Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)
i = i + 1
Next
GetSMTPAddressesForRecipients = Addresses
End Function
This will loop through all recipients within the email, and capture their names and emails, putting each one into the next spot within the array. Next, we need to use this information within your routine:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
Dim EmailSubject As String
EmailSubject = LCase(Item.Subject)
If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
Dim Addresses As Variant
Addresses = GetSMTPAddressesForRecipients(Item)
Dim i As Long
For i = LBound(Addresses, 1) To UBound(Addresses, 1)
If Addresses(i, 1) = "David#abclimited.net" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
Exit For
End If
Next
End If
End Sub
A couple of things to note here. First, your pattern was using lowercase for the subject, so you will want to convert the subject to lowercase so that, if you have a subject like "Update the Revision" your pattern still catches it.
Second, I put the most likely condition up front, that is, most of your email subjects will not contain "Subject" or "Revision". There's no need to then ask the server for the addresses of the recipients. Previously, your code would get the address before checking if it needed it. Its best to only ask for what we need, it makes your code easier to read, and maintain while also reducing any processing cost.
Finally, this code will loop through all addresses and not just look at the first one. By doing this, you will still trigger the alert even if he is the second, or third, or fiftieth address in the list.
I hope this helps! Here's the code in entirety:
Option Explicit
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Note that I explicitly convert the subject to lowercase since the patterns use lowercase
Dim EmailSubject As String
EmailSubject = LCase(Item.Subject)
If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then
Dim Addresses As Variant
Addresses = GetSMTPAddressesForRecipients(Item)
Dim i As Long
For i = LBound(Addresses, 1) To UBound(Addresses, 1)
If Addresses(i, 1) = "David#abclimited.net" Then
MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?"
Exit For
End If
Next
End If
End Sub
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant
Dim Recipients As Outlook.Recipients
Set Recipients = MailItem.Recipients
Dim Addresses As Variant
ReDim Addresses(0 To Recipients.Count - 1, 0 To 1)
Dim Accessor As Outlook.PropertyAccessor
Dim Recipient As Outlook.Recipient
For Each Recipient In Recipients
Set Accessor = Recipient.PropertyAccessor
Dim i As Long
Addresses(i, 0) = Recipient.Name
Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS)
i = i + 1
Next
GetSMTPAddressesForRecipients = Addresses
End Function
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
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.