I'm trying to check outgoing email addresses and to do so I use the following code:
Dim objMail As Outlook.MailItem
Set objMail = Item
Dim objRecipients As Outlook.Recipients
Set objRecipients = objMail.Recipients
and use it like this:
Set objRecipients = objMail.Recipients
For i = objRecipients.Count To 1 Step -1
vntRecipients.Add objRecipients.Item(i).Address
Debug.Print "Recipient"
Debug.Print objRecipients.Item(i).Address
Next
Afterwards I have all addresses in vntRecipients. When I look at the log file I see, that it's not always an email address but very often (all internal email addresses, but also external email addresses) something like this:
/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDXYXYXYXYXYXYXY)/CN=RECIPIENTS/CN=BYXXYXYXYXYXYXYXYXYXYXYXYXYX0B-S.BLALBA
There are different formats, but I guess it's due to the O365 Exchange server.
Is there any way to get the email address to compare the domain to my trusted domain list?
I haven't tested but the docs probably suggest using the following:
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = "https://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set pa = objRecipients.Item(i).PropertyAccessor
Debug.Print objRecipients.Item(i).name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
Source: https://learn.microsoft.com/en-us/office/vba/outlook/concepts/address-book/obtain-the-e-mail-address-of-a-recipient
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.
We have an Outlook VSTO Add-In that is checking the Outlook.Recipients domain to see if the addressee is going external to our network
Dim objRecipients As Outlook.Recipients
So say there are 2 recipients that we want to loop through and check the domain:
Do While objRecipients.Count >= loopCount
If InStr(1, objRecipients(loopCount).Address, "#") Then
...
End If
Loop +=1
Loop
For an external objRecipient(loopCount).Address we're seeing, say:
gmail.com
Which is good.
However, for internal addresses, we seem to be seeing LDAP/Exchange addresses instead of SMTP addresses like this:
/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=9asd9asd9d9d9asd9asd9asd9asd9asd9asd-Fred Smith"
This seemed to just start happening, but not sure why or how to fix this problem.
Any idea of why this occurs?
Thanks
Following this article helped us fix our issue:
https://learn.microsoft.com/en-us/office/vba/outlook/Concepts/Address-Book/obtain-the-e-mail-address-of-a-recipient
We needed to use the Outlook.PropertyAccessor property to get the correct SMTP Address:
Dim objRecipients As Outlook.Recipients
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String =
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Do While objRecipients.Count >= loopCount
'set propertyaccessor object
pa = objRecipients(loopCount).PropertyAccessor
'set propertyaccessor domain based on smtp address
paDomain = pa.GetProperty(PR_SMTP_ADDRESS)
Loop +=1
Loop
I've written a script that forwards incoming emails to the right people based on the contents of an excel spreadsheet.
The problem is it that does this by putting the name of the addressee into the .To field of the message (ie John Smith - not john.smith#example.com), and then looking up the actual address when I invoke the .Send method, Outlook seems to decide to sometimes look up the contacts email address via the "LinkedIn Social Connector".
How do I force it to look up the person's email address in the "Global Address List"?
You can get the address from the GAL rather letting Outlook determine it.
From the example here http://msdn.microsoft.com/en-us/library/office/ff869721(v=office.15).aspx
Untested code
Option Explicit
Sub DemoAE_ToName
Dim colAL As Outlook.AddressLists
Dim oAL As Outlook.AddressList
Dim colAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser
Set colAL = Application.Session.AddressLists
For Each oAL In colAL
'Address list is an Exchange Global Address List
If oAL.AddressListType = olExchangeGlobalAddressList Then
Set colAE = oAL.AddressEntries
For Each oAE In colAE
' no distribution lists
If oAE.AddressEntryUserType = _
olExchangeUserAddressEntry _
Or oAE.AddressEntryUserType = _
olExchangeRemoteUserAddressEntry Then
If oAE.Name = "John Smith" then
Set oExUser = oAE.GetExchangeUser
Debug.Print (oExUser.PrimarySmtpAddress)
end if
End If
Next
End If
Next
End Sub
You can set up a function to pass ToName and return oExUser.PrimarySmtpAddress
Rather than
For Each oAL In colAL
If oAL.AddressListType = olExchangeGlobalAddressList Then
You should be able to drop some code with
Set oAL = Application.Session.AddressLists("Global Address List")
Edit: Re: Comments - Tough crowd.
Edit 2: Appears Restrict is not available
Tested Code where the address is retrieved when the name is known.
Sub AddressEntry_DirectAccess()
Dim oNS As Namespace
Dim oExUser As exchangeUser
Set oNS = Application.GetNamespace("MAPI")
Set oExUser = oNS.AddressLists("Global Address List").AddressEntries("Last, First").GetExchangeUser()
If Not oExUser Is Nothing Then
Debug.Print oExUser.name & ": " & oExUser.PrimarySmtpAddress
End If
End Sub
Firstly, you can specify the right name resolution order in Outlook if you hit Ctrl+Shift+B, Tools | Options.
If you were using C++ or Delphi, you could use Extended MAPI: retrieve the GAL's IABContainer interface and apply PR_ANR restriction.
If you using Redemption (I am its author) is an option, you can use RDOSession.AddressBook.GAL to retrieve the GAL container, then use RDOAddressList.ResolveName to resolve against that particular container only.
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.
How can I ensure the contacts I add to an Outlook distribution list are displayed with both name and email address? These contacts may not exist in any other address book, just the distribution list. Currently they show up just as an email address (in both columns).
alt text http://img52.imageshack.us/img52/1804/tempgg.jpg
Here's roughly the VBA we're using:
Do Until RS.EOF
//here's where we want to inject RS!FirstName, RS!Surname etc
objRecipients.Add RS!Email
objRecipients.Resolve
RS.MoveNext
Loop
Set objDistList = contactsFolder.Items.Add("IPM.DistList")
objDistList.DLName = "Whatever"
objDistList.AddMembers objRecipients
objDistList.Save
etc
I think you have to create a ContactItem for each recipient so you can define the name. Here's an example:
Sub testdistlist()
Dim oRecips As Recipients
Dim ciDist As DistListItem
Dim ci As ContactItem
Dim mi As MailItem
Set mi = Application.CreateItem(olMailItem)
Set oRecips = mi.Recipients
Set ciDist = Application.CreateItem(olDistributionListItem)
'replace this with your recordset loop
Set ci = Application.CreateItem(olContactItem)
ci.FirstName = "John"
ci.LastName = "Lennon"
ci.Email1Address = "jlennon#example.com"
ci.Save
oRecips.Add ci.FullName
Set ci = Application.CreateItem(olContactItem)
ci.FirstName = "Ringo"
ci.LastName = "Starr"
ci.Email1Address = "rstarr#example.com"
ci.Save
oRecips.Add ci.FullName
'end replace
ciDist.AddMembers oRecips
ciDist.Save
ciDist.Display
mi.Close olDiscard
End Sub
Thanks to Dick Kusleika for his answer but Graeme's answer here gave me an idea there could be an easier way.
And that is just to use angle brackets in the entry to the distribution list. As in "Ringo Starr<rstarr#example.com>"
Which works just fine.
So my original example would look like this:
objRecipients.Add RS!FullName & "<" & RS!Email & ">"