The following should do the trick when run as a script from a rule that acts on all messages (or all messages from a particular sender)
The code will adapt to either scenario, but if you are moving to a sub folder of Inbox called "Old Transactions" that folder must exist.
You can test the code on a selected message using the TestCode macro.
Option Explicit
Sub TestCode()
Dim olMsg As MailItem
On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
OldData olMsg
lbl_Exit:
Exit Sub
End Sub
Sub OldData(olItem As MailItem)
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim dDate As Date, dRecDate As Date
Dim sDate As String, sRecDate As String
Dim oFldr As Folder
If TypeName(olItem) = "MailItem" Then
If InStr(1, olItem.Body, "Transaction Date: ") > 0 Then
Set oFldr = Session.GetDefaultFolder(olFolderInbox).folders("Old Transactions")
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute("Transaction Date: ")
oRng.collapse 0
oRng.End = oRng.End + 21
If IsDate(oRng.Text) = True Then
dDate = CDate(oRng.Text)
sDate = Format(dDate, "yyyymmddHHMM")
dRecDate = DateAdd("n", -15, olItem.ReceivedTime)
sRecDate = Format(dRecDate, "yyyymmddHHMM")
If Val(sDate) < Val(sRecDate) Then
' olItem.Delete
olItem.Move oFldr
End If
End If
Exit Do
Loop
End With
End With
End If
End If
lbl_Exit:
Set oRng = Nothing
Set wdDoc = Nothing
Set olInsp = Nothing
Set olItem = Nothing
Set oFldr = Nothing
Exit Sub
End Sub