I was able to do this by limiting the search area to whatever is above the email header of the second email in the thread.
enter code here
Sub CheckTopBodyWords(olItem As Outlook.MailItem)
Dim strBody As String
Dim searchWords As String
Dim found As Boolean
searchWords = "WORD" ' Replace with your specific words, separated by a pipe (|) symbol
strBody = GetTextAboveHeader(olItem.Body)
found = False
If InStr(1, strBody, searchWords, vbTextCompare) > 0 Then
found = True
End If
If found Then
' Replace "Your Folder Name" with the name of your desired folder.
olItem.Move Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("TEST")
End If
End Sub
Function GetTextAboveHeader(fullBody As String) As String
Dim emailHeaderPatterns As Variant
emailHeaderPatterns = Array("To:", "From:", "Subject:", "Date:")
' Add more header patterns as needed
Dim foundHeader As Boolean
foundHeader = False
Dim result As String
result = ""
Dim lines As Variant
lines = Split(fullBody, vbCrLf)
Dim line As Variant
For Each line In lines
If Not foundHeader Then
Dim headerPattern As Variant
For Each headerPattern In emailHeaderPatterns
If LCase(Left(line, Len(headerPattern))) = LCase(headerPattern) Then
foundHeader = True
Exit For
End If
Next headerPattern
End If
If foundHeader Then
Exit For
Else
result = result & line & vbCrLf
End If
Next line
GetTextAboveHeader = result
End Function
Function RegExpTest(str As String, pattern As String) As Boolean
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
regEx.pattern = pattern
regEx.IgnoreCase = True
regEx.Global = True
RegExpTest = regEx.Test(str)
End Function