I'm currently in the process of creating something that will search my outlook inbox (Email body and subject) for a 'Key word' and list results in excel. I have created the below and completed some testing however i'm not confident in the accuracy of the results. I had to stop the macro mid running as i was expecting around 30 results whereas the results exceeded 3,000.I'd looking for help in identifying any errors in the below VBA
Any help is much appreciated!
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") Set outStartFolder = outNs.Folders("firstname.lastname@example.org").Folders("Inbox") If Not outStartFolder Is Nothing Then Set foundEmail = Find_Email_In_Folder(outStartFolder, Sheet1.Range("E2").Text) 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 Dim arrHeader As Variant Debug.Print outFolder.FolderPath Set Find_Email_In_Folder = Nothing 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 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 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