VBA code for OUTLOOK to DELETE incoming EMAILS based on text in the BODY

[mb2404]

Is there a way using VBA to have OUTLOOK delete any incoming email that meet 2 conditions below.


Condition #1

The body of the email must contain the following text string with variable date and time:


Transaction Date: XX/XX/XXXX XX:XX:XX AM/PM


Where XX/XX/XXXX is the date written in the following format: m/d/yyyy and time is 12hr time in the following format h:mm:ss AM/PM


Here is the string with a date and time as an example


Transaction Date: 9/21/2021 2:13:01 PM


Note: The body of the email contains other lines of text both before and after this specific string.


Condition #2


The date and time shown in the Transaction Date line is no more than 15 minutes from the date/time the email was received (based on the time stamp of the email).
For example, an email with time stamp 10/21/2021 1:42PM and containing the string below in the body would not be deleted


Transaction Date: 10/21/2021 1:38:13 PM


If it was any other date however, or the time was >15mins it would be deleted, like these 2:


Transaction Date: 10/21/2021 11:01:20 AM


Or


Transaction Date: 9/3/2021 1:44:01 PM



If this VBA code is possible, could it instead move the email to a folder named Old Transactions? If so, what would that code look like?

Also, how would the code change if it only needed to be run to delete/move already received emails?


Thank you to anyone that can help

[gmayor]

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

[mb2404]

So the code worked -- once -- I think. I'm very new to VBA, so I must be doing something incorrect on my end with the running of the code in VBA. It will do me good to mess with it myself to get it to work again. But.....

I noticed a mistake on my end and perhaps why I can't get it to work any more.

The time and date format of the incoming email is in fact in this format:

Transaction Date: mm/dd/yyyy XX:XX:XX

Example:

Transaction Date: 09/20/2021 03:22:11

It's 24 hour time with no AM or PM and in the mm/dd/yyyy format

How would that change the code.

I was looking at an older email that had a different date/time format.

Thank you so much for your QUICK help.

[gmayor]

Change the line

oRng.End = oRng.End + 21
to

oRng.End = oRng.End + 19