Find Outlook Email with keywords in Subject & attachment using Excel VBA - excel

I am trying to search Outlook for the most recent email with "Blue Recruit Req Data" in the Subject line.
There will be additional words in the subject line.
When an email is found I need to verify that it has an attachment.
I want to store the subject & the received date in variables and compare them to previous subject & date stored in the Excel file running the macro.
If the subject lines don't match & the date of the email is after the date last stored in the Excel file, then I want to save that attachment in a folder.
It is not finding emails that contain "Blue Recruit Req Data" in the subject.
Sub CheckEmail_BlueRecruit()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim olAp As Object, olns As Object, olInb As Object
Dim olItm As Object, olAtch As Object, olMail As Object
'Outlook Variables for email
Dim sSubj As String, dtRecvd As String
Dim oldSubj As String, olddtRecvd As String
Sheets("Job Mapping").Visible = True
Sheets("CC Mapping").Visible = True
Sheets("Site Mapping").Visible = True
Sheets("Historical Blue Recruit Data").Visible = True
Sheets("Historical HRT Data").Visible = False
Sheets("Combined Attrition Data").Visible = True
Sheets.Add Before:=Sheets(1)
'Designate ECP Facilities Model file as FNAME
myPath = ThisWorkbook.Path
MainWorkbook = ThisWorkbook.Name
Range("A1").Select
ActiveCell.FormulaR1C1 = myPath
'designate file path for Attrition Files
FacModPath = Cells(1, 1).Value
Sheets(1).Delete
'Get Outlook Instance
Set olAp = GetObject(, "Outlook.application")
Set olns = olAp.GetNamespace("MAPI")
Set olInb = olns.GetDefaultFolder(6)
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
'Chec if there are any matching emails
If Not (olMail Is Nothing) Then
For Each olItm In olMail
If myItem.Attachments.Count <> 0 Then
dtRecvd = olItm.ReceivedTime
sSubj = olItm.Subject
oldSubj = Sheets("CC Mapping").Range("M2").Value
olddtRecvd = Sheets("CC Mapping").Range("M3").Value
If sSubj = oldSubj Or dtRecvd <= olddtRecvd Then
MsgBox "No new Blue Recruit data files to load."
Exit Sub
Else
Range("M2").Select
ActiveCell.FormulaR1C1 = sSubj
Range("M3").Select
ActiveCell.FormulaR1C1 = dtRecvd
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".xlsx") Then
I = I + 1
myAttachment.SaveAs Filename:=FacModPath & "\" & myAttachment.DisplayName
Exit For
Else
MsgBox "No attachment found."
Exit For
End If
Next
End If
End If
Next
Else
MsgBox "No emails found."
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
A separate, but related question. I want to search for emails that are in the Outlook Archive folder, or even a subfolder of Inbox. Do I need to format this line of code any differently?
Set olInb = olns.GetDefaultFolder(6)

Of course, iterating over all items in a folder is not really a good and right idea. You need to use the Restrict or Find/FindNext methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
In the code posted above I've noticed the following line:
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
Be aware, the Restrict methods return an instance of the Items class which contains a collection of items that correspond to your condition, not a single item as you could think. For example:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, I'd change the filter string to include entries that may contain the passed substring:
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & wordsInSubject & " %'"
To get items ordered, i.e. start from the recent or oldest ones you need to sort the collection by using the Sort methods of the Items class:
Items.Sort("[ReceivedTime]")
Finally, you may also find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about the AdvancedSearch method and find the sample code in the Advanced search in Outlook programmatically: C#, VB.NET article.

I have refactored some of your code so you can take advantage of calling procedures and organize your logic.
I didn't include all of your code though, but as I can see, you have enough knowledge to make it work.
A couple of suggestions:
1- Use option explicit at the top of your modules
2- Try to define your variables to something meaningful (use names anybody can understand)
3- Try to indent your code consistently (you could use RubberDuck
Before pasting your code:
Use early binding to set the reference to Outlook object library and take advantage of intellisense and other benefits
1) Click on tools | References
2) Check the Microsoft Outlook XXX Object Library
Here is the refactored code:
Execute it using F8 key and adjust it to fit your needs
Public Sub CheckEmail_BlueRecruit()
' Declare objects
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim outlookFolder As Outlook.MAPIFolder
' Declare other variables
Dim filterKeywords As String
Dim filter As String
' Init objects
Set outlookApp = New Outlook.Application
Set outlookNamespace = Outlook.GetNamespace("MAPI")
Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
' Init other variables
filterKeywords = "financial"
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"
' Loop through folders
LoopFolders outlookFolder, filter
End Sub
Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
' DeclareObjects
Dim outlookSubFolder As Outlook.MAPIFolder
Dim outlookMail As Outlook.MailItem
ProcessFolder outlookFolder, filter
If outlookFolder.Folders.Count > 0 Then
For Each outlookSubFolder In outlookFolder.Folders
LoopFolders outlookSubFolder, filter
Next
End If
End Sub
Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
Dim outlookItems As Outlook.Items
Dim outlookMail As Outlook.MailItem
' Filter folder
Set outlookItems = outlookFolder.Items.Restrict(filter)
If Not outlookItems Is Nothing Then
For Each outlookMail In outlookItems
If outlookMail.Attachments.Count <> 0 Then
Debug.Print outlookMail.Subject
End If
Next outlookMail
End If
End Sub
Let me know if it works and you need any more help

Related

Look through 2 outlook root folders in Excel with VBA

I have managed to get access to the items in 2 folders in Outlook from Excel by using VBA, but now I want to search for the email address x#gmail.com in both aI know how to search each one individually, but once, and sort for the most recent one. The piece I am stuck on is how to look through both folders at once.
I am using Microsoft Office 2016
Obviously, this dummy line does not do the trick: Set olJoinedFldr = olCleanUp + olFldr
Private Sub CommandButton2_Click()
Dim olApp As Outlook.Application 'set app
Dim olNs As Object 'get namespace
Dim olFldr As Outlook.Folder 'to be the inbox
Dim olArchive As Outlook.Folder 'the archive folder
Dim olCleanUp As Outlook.Folder ' the archive subfolder we need
Dim olJoinedFldr As Object 'the to be made joined object to filter....
Dim olItems As Object 'filtered items based on search criteria
Dim olItemReply As Object 'the reply mail
Dim i As Long
Dim emailStr As String
Dim filter As String
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(6) ' olFolderInbox
Set olArchive = olNs.Folders(CStr(olNs.Accounts.Item(1))) 'find email of current user
Set olCleanUp = olArchive.Folders("Archive").Folders("Cleanup") ' get the archive sub folder
Set olJoinedFldr = olCleanUp + olFldr
Set emailStr = "somebody#gmail.com"
filter = "[SenderEmailAddress] = """ & emailStr & """" 'this is the email from person x we are searching for in the 2 folders
' from here on it is currently searching just 1 folder
Set olItems = olFldr.Items.Restrict(filter) 'filter the items
olItems.Sort "[ReceivedTime]", True 'sort by date
If olItems.Count > 0 Then
For i = 1 To olItems.Count
If olItems(i).Class = 43 Then
Set olItemReply = olItems(i).ReplyAll
With olItemReply
.HTMLBody = "<p Dear someone, <br><br></p>" & .HTMLBody
.Display
End With
Exit For
End If
Next
Else
' have code here to make a brand new email already
End If
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set olArchive = Nothing
Set olCleanUp = Nothing
Set olJoinedFldr = Nothing
Set olItems = Nothing
Set olItemReply = Nothing
Set i = Nothing
Set emailStr = Nothing
Set filter = Nothing
End Sub
You cannot search through two (or more) folders unless you create a Search object using Application.AdvancedSearch. Even then, it is a PITA to work with - the search is asynchronous, and you would need to use events to figure out when the search is completed.
You'd be better off searching one folder at a time and combining the results (if necessary) in your code.
You need to use the AdvancedSearch method of the Application class. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about this method in the Advanced search in Outlook programmatically: C#, VB.NET article.

Join n outlook items into one new object with excel vba

I am looking for emails from person x in n outlook folders in Excel with VBA. What I want to do is find the most recent item of the n results (or of more folders).
I considered merging the n objects, sort by ReceivedTime and then get the top item, but I can't manage merging them, or find the most recent of the n objects.
Example is for 2 folders, 2 items:
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Folder 'to be the inbox
Dim olArchive As Outlook.Folder 'my archive folder
Dim olItems As Outlook.Items
Dim olArchiveItems As Outlook.Items
Dim i As Long
Dim emailStr As String
Dim filter As String
Dim olSentFldr as Outlook.Folder
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(6) ' olFolderInbox
Set olArchive = olNs.Folders(CStr(olNs.Accounts.Item(1)))
Set olSentFldr = olNs.GetDefaultFolder(olFolderSentMail)
emailStr = "somebody#outlook.com"
filter = "[SenderEmailAddress] = """ & emailStr & """"
Set olItems = olFldr.Items.Restrict(filter)
Set olArchiveItems = olArchive.Items.Restrict(filter)
olItems.Sort "[ReceivedTime]", True
olArchiveItems.Sort "[ReceivedTime]", True
olSentFldr.Sort "[ReceivedTime]", True
Dim olNew as Object
` below hypothetical solution that does not work yet--------------
olNew = merge(olItems(1), olArchiveItems(1))
olNew.Sort "[ReceivedTime]", True
myOutcome = olNew(1)
You can compare search results.
Option Explicit
Private Sub mostRecentItem_MultipleSearches()
' Early Binding - requires reference to Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.namespace
Dim olFldr As Outlook.Folder 'to be the inbox
Dim olSentFldr As Outlook.Folder
Dim olFldrItems As Outlook.Items
Dim olSentFldrItems As Outlook.Items
Dim olItemRecent As Object
Dim i As Long
Dim emailStr As String
Dim filter As String
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
' valid with early binding
Set olFldr = olNs.GetDefaultFolder(olFolderInbox) ' 6 if late binding
Set olFldrItems = olFldr.Items
Debug.Print "olFldrItems.count: " & olFldrItems.count
emailStr = "somebody#outlook.com"
filter = "[SenderEmailAddress] = """ & emailStr & """"
olFldrItems.Sort "[ReceivedTime]", True
Set olFldrItems = olFldrItems.Restrict(filter)
Debug.Print "olFldrItems.count: " & olFldrItems.count
Set olItemRecent = olFldrItems(1)
'olItemRecent.Display
Set olSentFldr = olNs.GetDefaultFolder(olFolderSentMail)
Set olSentFldrItems = olSentFldr.Items
olSentFldrItems.Sort "[SentOn]", True
Debug.Print "olSentFldrItems.count: " & olSentFldrItems.count
Debug.Print olItemRecent.ReceivedTime
Debug.Print olSentFldrItems(1).SentOn
If olItemRecent.ReceivedTime < olSentFldrItems(1).SentOn Then
Set olItemRecent = olSentFldrItems(1)
End If
olItemRecent.Display
End Sub
First of all, you need to Sort collection before running the Restrict of Find/FindNext methods if you want to get items ordered.
olItems.Sort "[ReceivedTime]", True
olArchiveItems.Sort "[ReceivedTime]", True
olSentFldr.Sort "[ReceivedTime]", True
filter = "[SenderEmailAddress] = """ & emailStr & """"
Set olItems = olItems.Restrict(filter)
Set olArchiveItems = olArchiveItems.Restrict(filter)
Try using not a straight comparison in the search string:
filter = Chr(34) & "[SenderEmailAddress]" & Chr(34) & " like '%" & emailStr &"'"`
It looks like you need to use the AdvancedSearch method of the Application class which performs a search based on a specified DAV Searching and Locating (DASL) search string. You can run the search in multiple folders at once. So, there is no need to run the search separately for each folder:
Set olItems = olFldr.Items.Restrict(filter)
Set olArchiveItems = olArchive.Items.Restrict(filter)
You can run it once for all folders and the search is performed in the background. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about the AdvancedSearch method in the Advanced search in Outlook programmatically: C#, VB.NET article.

Extract pdf files from an email from a specific contact (sender) and different inbox address in outlook

Good morning friends,
Please, I need your help, I have 2 problems:
1.- I wanted to be able to extract pdf files but an email from a specific contact (sender)
2.- I have several inboxes, how could I set another inbox, but not the one that comes by default - here I tried the following "Set Inbox = olNs.GetDefaultFolder (onothermail#gmail.com)" but it did not work for me
Thank you very much in advance
Option Explicit
Public Sub Example()
'// Declare your Variables
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Outlook.MailItem
Dim Atmt As Attachment
Dim Filter As String
Dim FilePath As String
Dim AtmtName As String
Dim i As Long
Dim objOwner As Outlook.Recipient
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set objOwner = olNs.CreateRecipient("secondMail#gmail.com")
Set Inbox = olNs.GetSharedDefaultFolder(objOwner)
FilePath = "C:\Users\Unity\Desktop\adjuntos\"
Filter = "[Unread] = True"
Set Items = Inbox.Items.Restrict(Filter)
'// Loop through backwards
For i = Items.Count To 1 Step -1
Set Item = Items(i)
DoEvents
If Item.Class = olMail Then
If Item.SenderEmailAddress = "senderx#gmail.com" Then
For Each Atmt In Item.Attachments
AtmtName = FilePath & Atmt.FileName
If ((InStr(Atmt.DisplayName, ".jpg") Or InStr(Atmt.DisplayName, ".zip") Or InStr(Atmt.DisplayName, ".PDF") Or InStr(Atmt.DisplayName, ".pdf"))) Then
Atmt.SaveAsFile FilePath & "\" & Atmt.DisplayName
End If
Item.UnRead = False
Next
End If
End If
Next
Set Inbox = Nothing
Set Items = Nothing
Set Item = Nothing
Set Atmt = Nothing
Set olNs = Nothing
End Sub
It seems additionally you need to check the sender's email address of the item. The MailItem.SenderEmailAddress property returns a string that represents the email address of the sender of the Outlook item.
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Outlook.MailItem
Dim i As Integer
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
' Loop all items in the Inbox\Test Folder
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.SenderEmailAddress = "someone#example.com" Then
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
End If
Next
End Sub
However, iterating over all items in the folder is not really a good idea. Use the Find/FindNext or Restrict methods of the Items class. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may use the AdvancedSearch method of the Application class helpful. See Advanced search in Outlook programmatically: C#, VB.NET for more information.
Use the Store.GetDefaultFolder method instead. It returns a Folder object that represents the default folder in the store and that is of the type specified by the FolderType argument. This method is similar to the GetDefaultFolder method of the NameSpace object. The difference is that this method gets the default folder on the delivery store that is associated with the account, whereas NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile.

MailItem.Send in VBA not functioning since Office 365 upgrade

We send out a lot of spreadsheets around the organisation, in order to automate this as much as possible we wrote some code to send this automatically and allow us to still put body text in.
This particular Script picks information up from our Finance System (SAP) dumps it into Excel and emails it to the user, it loops through a number times downloading and emailing different data each time.
This works fine on our old windows 7 (Office 2010) machines but some of us have been given new Windows 10 (Office 365) machines to pilot.
The code runs without any error messages but when it gets to .Send it jumps straight to End Sub and does not send the email.
I have tried EmailItem.Display and you can see the email being populated and then just stays visible on the desktop as it loops through the rest of the emails.
Any ideas on how to get round this? I could use the application.send function but I like to have the ability to add custom text into the email body.
Thanks :)
Sub EmailData()
Dim OL As Object
Dim EmailItem As Object
Dim y As Long
Dim TempChar As String
Dim Bodytext As String
Dim Flds As Variant
Dim EmailText As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Email Download to nursery
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.Createitem(OLMailItem)
'Check File Name is correct
Filename = Range("A1") & ".xls"
For y = 1 To Len(Filename)
TempChar = Mid(Filename, y, 1)
Select Case TempChar
Case Is = "/", "\", "*", "?", """", "<", ">", "|"
Case Else
SaveName = SaveName & TempChar
End Select
Next y
ActiveSheet.Cells.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
With ActiveWindow
.DisplayGridlines = False
.DisplayZeros = False
End With
Range("A1:S38").Select
Selection.Locked = True
Selection.FormulaHidden = False
Set EmailText = ActiveSheet.Range("AB1:AB5").SpecialCells(xlCellTypeVisible)
ActiveSheet.Protect ("keepsafe")
ActiveWorkbook.SaveAs Networkpath & "\" & SaveName, , "", , True
ActiveWorkbook.ChangeFileAccess xlReadOnly
EmailItem.display
'On Error Resume Next
With EmailItem
.To = "Daston#blahblah.uk"
'.To = Range("AA1")
.CC = ""
.BCC = ""
.Subject = Filename
.HTMLBody = RangetoHTML(EmailText)
.Attachments.Add ActiveWorkbook.FullName
.send
End With
Application.Wait (Now + TimeValue("0:00:02"))
Kill Networkpath & "\" & SaveName
ActiveWorkbook.Close False
Set OL = Nothing
Set EmailItem = Nothing
End Sub
This describes how, in certain situations, you may "make the object model fully functional".
NameSpace.Logon Method (Outlook)
"first, instantiate the Outlook Application object, then reference a default folder such as the Inbox. This has the side effect of initializing MAPI to use the default profile and to make the object model fully functional."
Sub InitializeMAPI ()
' Start Outlook.
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
' Get a session object.
Dim olNs As Outlook.NameSpace
Set olNs = olApp.GetNamespace("MAPI")
' Create an instance of the Inbox folder.
' If Outlook is not already running, this has the side
' effect of initializing MAPI.
Dim mailFolder As Outlook.Folder
Set mailFolder = olNs.GetDefaultFolder(olFolderInbox)
' Continue to use the object model to automate Outlook.
End Sub
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses.
HKCU\Software\Policies\Microsoft\office\16.0\outlook\security\
promptoomaddressbookaccess
promptoomaddressinformationaccess
https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
The most probable cause is Outlook Security.
You can find the security configurations in HKCU\Software\Policies\Microsoft\office\16.0\outlook\security
(change 16.0 to your office version)
Change promptoomsend to 2 (or ask your system administrator), restart Outlook and try again.
More info https://support.microsoft.com/en-za/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

Extract text string from undeliverable email body to Excel

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.

Resources