Searching through outlook body for 'keyword'

[owen4512]

Hi all,

I've found and adapted the below after doing some searching online however I'm having some difficulties in adapting the code to my needs. The below currently searches through one of my subfolders in outlook for the value in sheet1.range("G1"). The issue I'm having is the below doesn't return all results. What I want the below to do is, continue searching through the full subfolder and list all results on sheet1 starting in cell A2.

I'm new outlook vba and would really appreciate some help on this

Option Explicit
Public Sub Search_Outlook_Emails()
 Dim outApp As Outlook.Application
 Dim outNs As Outlook.Namespace
 Dim outStartFolder As Outlook.MAPIFolder
 Dim foundEmail As Outlook.MailItem
 
 Set outApp = New Outlook.Application
 Set outNs = outApp.GetNamespace("MAPI")
 
 'Start at Inbox's parent folder
 'Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent
 
 'Or start at folder selected by user
 Set outStartFolder = outNs.Folders("owen@testemail.com").Folders("Inbox").Folders("BI")
 If Not outStartFolder Is Nothing Then
 
 Set foundEmail = Find_Email_In_Folder(outStartFolder, Sheet1.Range("G1").Value)
 
 End If
End Sub

Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem
 
 Dim outItem As Object
 Dim outMail As Outlook.MailItem
 Dim outSubFolder As Outlook.MAPIFolder
 Dim i As Long

 Debug.Print outFolder.FolderPath
 
 Set Find_Email_In_Folder = Nothing
 
 'Search emails in this folder
 
 i = 1
 While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing
 
 Set outItem = outFolder.Items(i)
 
 If outItem.Class = Outlook.OlObjectClass.olMail Then
 
 'Does the findText occur in this email's body text?
 
 Set outMail = outItem
 If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail
 
sheet1.Cells( i +1, "A").Value = outItem.CreationTime
sheet1.Cells( i +1, "B").Value = outItem.Subject

 End If
 
 i = i + 1
 
 Wend
 
 DoEvents
 
 'If not found, search emails in subfolders
 
 i = 1
 While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing
 
 Set outSubFolder = outFolder.Folders(i)
 
 'Only check mail item folders
 
 If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)
 
 i = i + 1
 
 Wend
 
End Function