I have a list of first and last names in Excel and I want to utilize that list to look up email address in Outlook using visual basic.
I'm using the following VB code:
Private Sub GetAddresses()
Dim o, AddressList, AddressEntry
Dim c As Range, r As Range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Global Address List")
Set r = Range("a1:a3")
For Each c In r
AddressName = Trim(c.Value) & ", " & Trim(c.Offset(0, 1).Value)
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
c.Offset(0, 2).Value = AddressEntry.Address
Exit For
End If
Next AddressEntry
Next c
End Sub
The code seems to be working fine up until the point of actually retrieving the email address. After it matches a name its returning the following instead of the address. Does anyone have an idea of what I'm doing wrong.
/O=Compnay/OU=Company/cn=Recipients/cn=shs
Thanks in advance for you help.
I am assuming that these are domain users. You want to get the SMTP address from the exchangeUser object. I have updated your code to show this.
Private Sub GetAddresses()
Dim o, AddressList, AddressEntry
Dim c As Range, r As Range, AddressName As String
'added variable for exchange user object
Dim exchangeUser As Outlook.exchangeUser
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Global Address List")
Set r = Range("a1:a3")
For Each c In r
AddressName = Trim(c.Value) ' & ", " & Trim(c.Offset(0, 1).Value)
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'set the exchange user object
Set exchangeUser = AddressEntry.GetExchangeUser
'get the smtp addresss
c.Offset(0, 2).Value = exchangeUser.PrimarySmtpAddress
'release
Set exchangeUser = Nothing
Exit For
End If
Next AddressEntry
Next c
End Sub
That looks like a perfectly valid address of type EX (as opposed to SMTP). Use AddressEntry.GetExchangeUser().PrimarySmtpAddress to retrieve the SMTP address.
Do not loop through all items in an address list that can potentially contains tens of thousands of entries. Use Aplication.Sesssion.CreateRecipient, then call Recipient.Resolve. If successful, you can retrieve the AddressEntry object from Recipient.AddressEntry.
If you need to make sure the name is resolved against GAL only (by the way, you should not hardcode the GAL name, it will differ based on locale), you can use Redemption (I am its author) and its AddreessList.ResolveName method - all you need to do is call RDOSession.AddressBook.GAL.ResolveName
Related
I am building a tool which is required to look up the GAL in Outlook to find a certain employee and return their email address, their manager & manager's email address & finally their manager & manager's email address.
I found code and adjusted it to search for a person's name; however, if you have two Bob Smiths I require this to be more specific in its search, either by email address or by alias.
Any code I found creates an array with all users in the exchange server; however, with millions of employee records this takes a large amount of time and this would run once per week to update the information.
Is there a way to search ideally by alias or secondly by SMTP email address?
I found versions of the code and I modified them to suit my requirements but still unable to find by alias or email address. If I do this manually I can click on advance search and type the alias or I click on "more columns" and search the alias and the correct result appears.
Can I define "More Columns" in the VBA code?
Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Dim i As Integer, r As Integer
Dim c As Range
Dim EndRow As Integer, n As Integer
Dim exchUser As Outlook.ExchangeUser
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNameSpace.AddressLists("Global Address List")
Dim FullName As String, LastName As String, FirstName As String
Dim LDAP As String, PhoneNum As String
Dim StartRow As Integer
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
StartRow = 2
For Each c In Range("I" & StartRow & ":I" & CStr(EndRow))
AliasName = LCase(Trim(c))
c = AliasName
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Set exchUser = myAddrEntry.GetExchangeUser
If Not exchUser Is Nothing Then
c.Offset(0, 1) = exchUser.FirstName
c.Offset(0, 2) = exchUser.LastName
c.Offset(0, 3) = exchUser.Alias
c.Offset(0, 4) = exchUser.PrimarySmtpAddress
c.Offset(0, 5) = exchUser.Manager
'etc...
End If
Next c
Have you checked the CreateRecipient namespace? https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.createrecipient
You could try creating a recipient object passing the alias to the CreateRecipient method:
Set myNamespace = Application.GetNamespace("MAPI")
Set recip = myNamespace.CreateRecipient("YourAlias")
recip.Resolve
You should of course check if your recipient was properly resolved by checking the resolved property:
If recip.Resolved Then
'Do something
After you got your recipient you can create an Exchange User from it using the GetExchangeUser method from the AdressEntry property in your recipient object.
Set exchUser = recip.AddressEntry.GetExchangeUser
Debug.Print exchUser.PrimarySmtpAddress
And I'm sure you can work it out from there!
I have been able to find a work around solution with the following function.
Function GetName(strAcc As String) As Variant
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient
'Dim strAcc As String
Dim maxTries As Long
Dim errCount As Long
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
Set lappRecipient = lappNamespace.CreateRecipient(strAcc)
maxTries = 2000
On Error GoTo errorResume
Retry:
DoEvents
' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
' Should normally be commented out
'Err.Raise 287
lappRecipient.Resolve
On Error GoTo 0
Set olAddrEntry = lappRecipient.AddressEntry
If lappRecipient.Resolved Then
Set olexchuser = olAddrEntry.GetExchangeUser
GetName = olexchuser.Name
Else
GetName = "Unable To Validate LDAP"
End If
ExitRoutine:
Set lappOutlook = Nothing
Set lappNamespace = Nothing
Set lappRecipient = Nothing
Exit Function
errorResume:
errCount = errCount + 1
' Try until Outlook responds
If errCount > maxTries Then
' Check if Outlook is there and Resolve is the issue
lappNamespace.GetDefaultFolder(olFolderInbox).Display
GoTo ExitRoutine
End If
'Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
Resume Retry
End Function
Is there a way to return the following Exchange Values to consolidate the function so it only looks in the exchange server once ?
Obtain .Name
.PrimarySmtpAddress
.Manager
.Manager.PrimarySmtpAddress
.Manager.Alias
I then loop through and Get Managers, Manager & Email.
I use the following SUB to be able to pull the information needed (Into a message box while building but the data will populate a table once finished).
Sub GetDetails()
Dim Name As String, Email As String, Manager As String, ManagersEmail As String, MD As String, MDEmail As String, Lookup As String
Lookup = GetManagerAlias("3511931") '("3359820")
Name = GetName(Lookup)
Email = GetEmail(Lookup)
Manager = GetManager(Lookup)
ManagersEmail = GetManagersEmail(Lookup)
MD = GetManager(GetManagerAlias(Lookup))
MDEmail = GetManagersEmail(GetManagerAlias(Lookup))
MsgBox Name & vbNewLine & Email & vbNewLine & Manager & vbNewLine & ManagersEmail & vbNewLine & MD & vbNewLine & MDEmail
End Sub
I have a list which contains:
- Clients
- Manager e-mail
- Head manager e-mail
I'm trying to send e-mails using VBA and Outlook, in a way that each time the loop finds one manager (I'm checking for an e-mail address), it sends every client listed for that manager.
If a branch has no manager e-mail address listed, the e-mail should go to the Head Manager (branch 1236, for example, would receive one e-mail, to the Head Manager, with several clients).
The e-mail body will contain pre formatted text, and after that the sheet list with the client list.
I'm having some troubles:
a) to list the branch's clients from the sheet to the mail body
b) to jump from the next manager after the first e-mail, instead of repeating the e-mail for the same manager every time the loop finds the same manager
c) logging the mail sent on the J column
This is a sheet with some of the report:
https://drive.google.com/file/d/1Qo-DceY8exXLVR7uts3YU6cKT_OOGJ21/view?usp=sharing
My loop works somewhat, but I believe I need some other approach to achieve this.
Private Sub CommandButton2_Click() 'envia o email com registro de log
Dim OutlookApp As Object
Dim emailformatado As Object
Dim cell As Range
Dim destinatario As String
Dim comcopia As String
Dim assunto As String
'Dim body_ As String
Dim anexo As String
Dim corpodoemail As String
'Dim publicoalvo As String
Set OutlookApp = CreateObject("Outlook.Application")
'Loop para verificar se o e-mail irá para o gerente da carteira ou para o gerente geral
For Each cell In Sheets("publico").Range("H2:H2000").Cells
If cell.Row <> 0 Then
If cell.Value <> "" Then 'Verifica se carteira possui gerente.
destinatario = cell.Value 'Email do gerente da carteira.
Else
destinatario = cell.Offset(0, 1).Value 'Email do Gerente Geral.
End If
assunto = Sheets("CAPA").Range("F8").Value 'Assunto do e-mail, conforme CAPA.
'publicoalvo = cell.Offset(0, 2).Value
'body_ = Sheets("CAPA").Range("D2").Value
corpodoemail = Sheets("CAPA").Range("F11").Value & "<br><br>" & _
Sheets("CAPA").Range("F13").Value & "<br><br>" ' & _
Sheets("CAPA").Range("F7").Value & "<br><br><br>"
'comcopia = cell.Offset(0, 3).Value 'Caso necessário, adaptar para enviar email com cópia.
'anexo = cell.Offset(0, 4).Value 'Caso necessário, adaptar para incluir anexo ao email.
'Montagem e envio dos emails.
Set emailformatado = OutlookApp.CreateItem(0)
With emailformatado
.To = destinatario
'.CC = comcopia
.Subject = assunto
.HTMLBody = corpodoemail '& publicoalvo
'.Attachments.Add anexo
'.Display
End With
emailformatado.Send
Sheets("publico").Range("J2").Value = "enviado"
End If
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Have a manager class that has a collection of clients. Have a collection of manager instances.
Manager Class
'#Folder("VBAProject")
Option Explicit
Private Type TManager
ManagerEmail As String
Clients As Collection
End Type
Private this As TManager
Private Sub Class_Initialize()
Set this.Clients = New Collection
End Sub
Private Sub Class_Terminate()
Set this.Clients = Nothing
End Sub
Public Property Get ManagerEmail() As String
ManagerEmail = this.ManagerEmail
End Property
Public Property Let ManagerEmail(ByVal value As String)
this.ManagerEmail = value
End Property
Public Property Get Clients() As Collection
Set Clients = this.Clients
End Property
Client Class
'#Folder("VBAProject")
Option Explicit
Private Type TClient
ClientID As String
End Type
Private this As TClient
Public Property Get ClientID() As String
ClientID = this.ClientID
End Property
Public Property Let ClientID(ByVal value As String)
this.ClientID = value
End Property
Standard Module
Option Explicit
Dim Managers As Collection
Sub PopulateManagers()
Set Managers = New Collection
Dim currWS As Worksheet
Set currWS = ThisWorkbook.Worksheets("publico")
With currWS
Dim loopRange As Range
Set loopRange = .Range(.Cells(2, 8), .Cells(.UsedRange.Rows.Count, 8)) 'H2 to the last used row; assuming it's the column for manager emails
End With
Dim currCell As Range
For Each currCell In loopRange
If currCell.value = vbNullString Then 'no manager; try for a head manager
If currCell.Offset(0, 1).value = vbNullString Then 'no managers at all
Dim currManagerEmail As String
currManagerEmail = "NoManagerFound"
Else
currManagerEmail = currCell.Offset(0, 1).Text
End If
Else
currManagerEmail = currCell.Text
End If
Dim currManager As Manager
Set currManager = Nothing
On Error Resume Next
Set currManager = Managers(currManagerEmail)
On Error GoTo 0
If currManager Is Nothing Then
Set currManager = New Manager
currManager.ManagerEmail = currManagerEmail
Managers.Add currManager, Key:=currManager.ManagerEmail
End If
Dim currClient As Client
Set currClient = New Client
currClient.ClientID = currWS.Cells(currCell.Row, 1).Text 'assumes client ID is in column 1
currManager.Clients.Add currClient, Key:=currClient.ClientID
Next
End Sub
once you have the collection of managers just loop that to create your manager-specific email.
Since I used Usedrange.Rows.Count to set up the range to loop it should have worked ok without an additional check. However, since I don't have your actual data to be sure, you may need it. I don't have line numbers, so I don't know what line 51 refers to. To loop the Managers:
Sub LoopManagers()
Dim currManager As Manager
For Each currManager In Managers
Debug.Print currManager.ManagerEmail
Dim currClient As Client
For Each currClient In currManager.Clients
Debug.Print currClient.ClientID
Next
Next
End Sub
You will need to adapt what I've provided to create your emails. Work on it. If you need more help post what you tried and describe what problems you have.
I would like to ask if there is a way to retrieve email address from outlook address book from the values enter in user form textbox and retrieve it.
For example, my textbox1 have user entering the full names of people they want to search and with a search button, textbox2 will have all the email address retrieve from outlook address book based on textbox1.
Currently what I have is, a module call retrieve email
Option Explicit
Sub GetAddresses()
Dim o, AddressList, AddressEntry
Dim c As Range, r As Range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Contacts")
'Chage this range to include the first names only. AddressName assignment line handles concatenating the last name.
Set r = Add.Emailname
For Each c In r
AddressName = c.Value & " " & c.Offset(0, 1).Value
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.name = AddressName Then
c.Offset(0, 2).Value = AddressEntry.Address
Exit For
End If
Next AddressEntry
Next c
End Sub
And in my user form, the search button
Private Sub Searchbutton_Click()
Call GetAddresses
End Sub
The code is what I have seen from online. Can anyone help me edit and guide me?
I see you have copied your code. This code is meant to loop around a range. You could simply remove the loop and inmplement your textbox value and assign it to your searchbutton. However you'll need a .ListBox1 (instead of .TextBox2) since you wanted to have all hits in contact to appear in a list. I've also implemented the .Instr function to see if the searchvalue appears in the contacts name (using LCase to be sure). This would making a search on just a lastname way easier. The code then would look like:
Option Explicit
Private Sub GetAddresses()
Dim o, AddressList, AddressEntry
Dim AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Contacts")
'Change this range accordingly
AddressName = UserForm1.TextBox1.Value
For Each AddressEntry In AddressList.AddressEntries
If InStr(1, LCase(AddressEntry.Name), LCase(AddressName)) <> 0 Then
UserForm1.ListBox1.AddItem AddressEntry.Address
End If
Next AddressEntry
End Sub
Private Sub Searchbutton_Click()
UserForm1.ListBox1.Clear
Call GetAddresses
End Sub
I have the following code to try and grab the GAL from Outlook and drop the person's name + their email address into another sheet.
It gets the first name (but not email address) then stops. If I comment out Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress, it lists all the names succesfully, which suggests I might be using the wrong type to get the email address. VBA has no intellisense though so I'm not sure what to use instead!
Private Sub UpdateEmails()
' Need to add reference to Outlook
' Adds addresses to existing Sheet called Emails and
' defines name NamesAndEmailAddresses containing this list
On Error GoTo error
Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim intCounter As Integer
Application.ScreenUpdating = False
' Setup connection to Outlook application
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Global Address List")
Application.EnableEvents = False
' Clear existing list
Sheets("Emails").Range("A:A").Clear
'Step through each contact and list each that has an email address
For Each objAddressEntry In objAddressList.AddressEntries
If objAddressEntry.Address <> "" Then
intCounter = intCounter + 1
Application.StatusBar = "Processing no. " & intCounter & " ... " & objAddressEntry.Address
Sheets("Emails").Cells(intCounter, 1) = objAddressEntry.Name
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress
DoEvents
End If
Next objAddressEntry
' Define range called "NamesAndEmailAddresses" to the list of emails
Sheets("Emails").Cells(1, 2).Resize(intCounter, 1).Name = "NamesAndEmailAddresses"
error:
Set objOutlook = Nothing
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Looking at the AddressEntry Object (Outlook) page on MSDN, the property you want is AddressEntry.Address
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.Address
Also, if you early-bind Outlook from the Tools > References...* then you will get Intellisense. Or, you can hit [Alt]+[F11] in Outlook and use the Intellisense there.
{EDIT} Since this is giving the path on the Exchange Server rather than as a full e-mail address
If the Contact is in an Exchange Address List, then you can use .GetExchangeUser.PrimarySmtpAddress to get the Primary Smtp Address for the user on the Exchange Server. (For local contacts on your account, use the GetContact.Email1Address instead)
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.GetExchangeuser.PrimarySmtpAddress
To obtain or check if a person has an email address on the GAL:
(see this solution)
Sub testGetEmail()
Debug.Print GetEmailName("Dupont", "Alain")
End Sub
Function GetEmailName(FirstName As String, SecondName As String) As String
Dim oExUser As Outlook.ExchangeUser
Dim oAL As Outlook.AddressList
Set oAL = Application.Session.AddressLists.Item(["Global Address List"])
FullName = FirstName & ", " & SecondName
Set oExUser = oAL.AddressEntries.Item([FullName]).GetExchangeUser
GetEmailName = oExUser.PrimarySmtpAddress
End Function
I am trying to extract the email address from each individual undeliverables email body.
The email body would be like:
----------------------------Email----------------------------
Delivery has failed to these recipients or groups:
XXXX#XXXXXX.XXX (XXXX#XXXXXX.XXX)
...no need info...
To: XXXX#XXXXXX.XXX
...no need info...
----------------------------Email-----------------------------
I came up with below code:
Sub Test()
Dim myFolder As MAPIFolder
Dim Item As Outlook.MailItem 'MailItem
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Lines() As String
Dim i As Integer, x As Integer, P As Integer
Dim myItem As Variant
Dim subjectOfEmail As String
Dim bodyOfEmail As String
'Try access to excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
If xlApp Is Nothing Then
MsgBox "Excel is not accessable"
Exit Sub
End If
End If
On Error GoTo 0
'Add a new workbook
Set xlWB = xlApp.Workbooks.Add
xlApp.Application.Visible = True
Set xlSheet = xlWB.ActiveSheet
Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each myItem In myFolder.Items
subjectOfEmail = myItem.Subject
bodyOfEmail = myItem.Body
'Search for Undeliverable email
If bodyOfEmail Like "*Delivery*" & "*failed*" And indexOfEmail Like "*Undeliverable*" Then
x = x + 1
'Extract email address from email body
Lines = Split(myItem.Body, vbCrLf)
For i = 0 To UBound(Lines)
P = InStr(1, Lines(i), "#", vbTextCompare)
Q = InStr(1, Lines(i), "(", vbTextCompare)
If P > 0 Then
xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) 'extract the email address
Exit For
End If
Next
End If
Next
End Sub
It worked on my test Email Inbox, which opened an Excel sheet and listed every particular email address within the target emails.
When I ran this code on my work email account, it didn't give me a thing. I found that it had trouble reading "Undeliverables" emails, and every time after I ran it, one of the undeliverables emails turned into Traditional Chinese characters which cannot be read.
格浴㹬格慥㹤洼瑥瑨灴攭畱癩∽潃瑮湥祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰∶猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨慦汩摥琠桴獥敲楣楰湥獴漠牧畯獰㰺是湯㹴⼼㹢⼼㹰昼湯⁴潣潬
I feel this code works on only forwarded undeliverable email, in my test email inbox.
It never read from the original undeliverable emails and turned those emails to Chinese characters one by one.
I googled it, it seems there are bugs in Outlook for the failed delivery emails. How to fix this?
After frustrated several days, I finally came up a much simpler solution, which doesn't need to worry about any restriction of NDR in Outlook or even never use VBA at all...
What I did is:
Select all the non-delivery emails in Outlook
Save as a ".txt" file
Open Excel, open the txt file and select "Delimited" and select "Tab" as delimiter in the "Text Import Wizard"
filter out the column A with "To:", then will get all the email address on column B
Can't believe this is much simpler than VBA...
Thank you guys for your help! Just can't really deal with the "Outlook NDR turning to unreadable characters" bug with so many restrictions on a work station, think this might be helpful!
For getting addresses... I can pull the address from the action.reply which creates an outlook message with a body and sender:
Sub Addressess_GET_for_all_selected()
Dim objSel As Selection
Dim i As Integer
Dim objMail As MailItem
Dim objRept As ReportItem
Dim oa As Recipient
Dim strStr As String
Dim objAct As Action
Set objSel = Outlook.ActiveExplorer.Selection
Dim colAddrs As New Collection
On Error GoTo 0
frmProgress.SetMax (objSel.Count)
'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR
On Error GoTo SkipObj: ''for unhandled types
For i = 1 To objSel.Count
Set objMail = Nothing
If objSel(i).Class = olReport Then ''report email addresses 2020-02-12
Set objRept = Nothing
Set objRept = objSel(i)
For Each objAct In objRept.Actions
If objAct.Name = "Reply" Then
Set objMail = objAct.Execute
Exit For
End If
Next objAct
End If
''fire on objmail or if is omail
If objSel(i).Class = olMail Then
Set objMail = objSel(i)
End If
If Not objMail Is Nothing Then
DoEvents
For Each oa In objMail.Recipients
colAddrs.Add GetSMTPAddress(oa.Address)
Next oa
On Error Resume Next '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
colAddrs.Add GetSMTPAddress(objMail.sender.Address)
On Error GoTo 0 '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
objMail.Delete
End If
SkipObj:
frmProgress.SetCurrent (i)
Next i
SortDedupCollection_PUSH colAddrs
frmProgress.Hide
End Sub
And GET SMTP:
Private Function GetSMTPAddress(ByVal strAddress As String) As String
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Recipient ' Object
Dim strRet As String
Dim fldr As Object
'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
On Error Resume Next
If InStr(1, strAddress, "#", vbTextCompare) <> 0 Then
GetSMTPAddress = strAddress
Exit Function
End If
Set olApp = Application
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
If fldr Is Nothing Then
olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Add "Random"
Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
End If
On Error GoTo 0
If CInt(Left(olApp.VERSION, 2)) >= 12 Then
Set oRec = olApp.Session.CreateRecipient(strAddress)
If oRec.Resolve Then
On Error Resume Next
strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
If strRet = "" Then
strRet = Split(oRec.AddressEntry.Name, "(")(2) ''at least provide name.
strRet = Left(strRet, InStr(1, strRet, ")") - 1)
End If
On Error GoTo 0
End If
End If
If Not strRet = "" Then GoTo ReturnValue
'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
'How it works
'============
'1) It will create a new contact item
'2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
'3) We will assign a random key to this contact item and save it in its Fullname to search it later
'4) Next we will save it to local contacts folder
'5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
'6) The display name will be something like this " ( email.address#server.com )"
'7) Now we need to parse the Display name and delete the contact from contacts folder
'8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
'9) We then need to delete it from Deleted Items folder as well, to clean all the traces
Set oCon = fldr.items.Add(2)
oCon.Email1Address = strAddress
strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
oCon.FullName = strKey
oCon.Save
strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
oCon.Delete
Set oCon = Nothing
Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
GetSMTPAddress = strRet
End Function
sI have been having exactly the same issue. All of the NDR messages I am dealing with are of the class "REPORT.IPM.Note.NDR" and the method I found for obtaining the original recipient was pieced together from a number of these sorts of posts and questions that I've been trawling through!
I am using the PropertyAccessor.GetProperty method against the ReportItem to obtain the PR_DISPLAY_TO property value from the header information of the ReportItem.
In VBA, I am using the MAPI namepace and looping through the olItems collection of a given folder containing the report messages. I'm running this from Access as my database front-end is built that way, but I would imagine you can probably run it from within Outlook VBA (but don't hold me to that).
Dim olApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.ReportItem
Dim OlItems As Outlook.Items
Set olApp = CreateObject("Outlook.Application")
Set OlMapi = olApp.GetNamespace("MAPI")
Set olFolder = OlMapi.Folders("SMTP-ADDRESS-FOR-YOUR-MAILBOX").Folders("Inbox").Folders("NAME-OF-SUBFOLDER_CONTAINING-NDR-REPORTS")
Set OlItems = olFolder.Items
If OlItem.Count > 0 Then
For Each olMail In OlItems
strEmail = olMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")
'DO WITH strEmail AS REQUIRED
DoEvents
Next
End If
The returned value from that MAPI property could be a semicolon delimited list where there are multiple recipients, so you could check for ';' in the returned string and then split into an array and iterate through to get each individual address, but in my case, there is only ever one recipient so I didn't need to over complicate it. It also may be a display name when the original recipient is a contact, so this may be a shortcoming for some, but again in my case, that's not a factor.
This is just a snippet of a bigger function so you will need to amend and integrate it to your needs, and obviously replace or amend the placeholders for the mailbox and subfolder values.
The intention is currently to also extract the NDR reason code so that I can automate removal of email addresses from our database where the reason is because the mailbox does not exist, so referring only to ReportItem object - This likely won't work for NDR emails which are not of that type, as I would image thoe MAPI properties are not available, however I have found in practice that all of the NDR messages come back like this as we are using Exchange Online.
I Did some tweaking to the original code in the first post,
and added a helper function to Extract Email From String, and seems to be working fine.
Sub List_Undeliverable_Email_To_Excel()
Dim myFolder As MAPIFolder
Dim Item As Outlook.MailItem 'MailItem
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Lines() As String
Dim i As Integer, x As Integer, P As Integer
Dim myItem As Variant
Dim subjectOfEmail As String
Dim bodyOfEmail As String
'Try access to excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
If xlApp Is Nothing Then
MsgBox "Excel is not accessable"
Exit Sub
End If
End If
On Error GoTo 0
'Add a new workbook
Set xlWB = xlApp.Workbooks.Add
xlApp.Application.Visible = True
Set xlSheet = xlWB.ActiveSheet
Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Real Estate").Folders("ag#joinreal.com")
For Each myItem In myFolder.Items
subjectOfEmail = myItem.Subject
bodyOfEmail = myItem.Body
'Search for Undeliverable email
If subjectOfEmail Like "*Undeliverable*" Or subjectOfEmail Like "*Undelivered*" Or subjectOfEmail Like "*Failure*" And subjectOfEmail Like "*Delivery*" Then 'bodyOfEmail Like "*Deliver*" And
x = x + 1
'Extract email address from email body
Lines = Split(bodyOfEmail, vbCrLf)
For i = 0 To UBound(Lines)
P = InStr(1, Lines(i), "#", vbTextCompare)
If P > 0 Then
EmailAdd = ExtractEmailFromString(Lines(i), True)
Debug.Print x & " " & EmailAdd
xlApp.Range("A" & x) = EmailAdd
Exit For
End If
Next
End If
Next
End Sub
Function ExtractEmailFromString(extractStr As String, Optional OnlyFirst As Boolean) As String
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
OutStr = ""
Index = 1
Do While True
Index1 = VBA.InStr(Index, extractStr, "#")
getStr = ""
If Index1 > 0 Then
For P = Index1 - 1 To 1 Step -1
If Mid(extractStr, P, 1) Like CheckStr Then
getStr = Mid(extractStr, P, 1) & getStr
Else
Exit For
End If
Next
getStr = getStr & "#"
For P = Index1 + 1 To Len(extractStr)
If Mid(extractStr, P, 1) Like CheckStr Then
getStr = getStr & Mid(extractStr, P, 1)
Else
Exit For
End If
Next
Index = Index1 + 1
If OutStr = "" Then
OutStr = getStr
If OnlyFirst = True Then GoTo E
Else
OutStr = OutStr & Chr(10) & getStr
End If
Else
Exit Do
End If
Loop
E:
ExtractEmailFromString = OutStr
End Function
There is a problem with the ReportItem.Body property in the Outlook Object Model (present in Outlook 2013 and 2016) - you can see it in OutlookSpy (I am its author): select an NDR message, click Item button, select the Body property - it will be garbled. Worse than that, once the report item is touched with OOM, Outlook will display the same junk in the preview pane.
The report text is stored in various MAPI recipient properties (click IMessage button in OutlookSpy and go to the GetRecipientTable tab). The problem is the ReportItem object does not expose the Recipients collection. The workaround is to either use Extended MAPI (C++ or Delphi) or Redemption (I am its author - any language) - its RDOReportItem.ReportText property does not have this problem:
set oItem = Application.ActiveExplorer.Selection(1)
set oSession = CreateObject("Redemption.RDOSession")
oSession.MAPIOBJECT = Application.Session.MAPIOBJECT
set rItem = oSession.GetRDOObjectFromOutlookObject(oItem)
MsgBox rItem.ReportText
You can also use RDOReportItem.Recipients collection to extract various NDR properties from the recipient table.