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

Question

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)

Answer 1

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.

Answer 2

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