How to retrieve any external email address? - vba

Question

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.

Answer 1

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