Small vba to kill political email

[TedSch]

I am on every political email list asking for money. Even though I unsubscribed, they were still coming in different candidates. There are a few major companies (political SaaS) that swap your name around to the difference candidates even when you are not living in the same state. If you look at the email's HTML source, you'll see ActBlue, Npvan, Sendgrid as the main ones if you are a democrat. There doesn't seem to be a way to make a rule that acts on hidden HTML source test. Below you'Il see the code I assigned to a button on the quick access tool bar. It works. It is easy to expand the array for any newcomers. Let me know if there is a better way. Would there be a way to make this a custom rule that operates when new emails arrive? Thank you Slipstick for being the go-to for Outlook.

Public Function ArrayTest(strToTest As String) As Boolean
Dim strTxtArray() As Variant
Dim k As Integer

strToTest = UCase(strToTest)

strTxtArray() = Array("ACTBLUE", "SENDGRID", "ACTIONNETWORK", "NPGVAN", "ACTIONKIT", "USO.ORG", "AMERICARES.ORG", "SIERRACLUB.ORG")

For k = LBound(strTxtArray) To UBound(strTxtArray)
'Debug.Print strTxtArray(k)
'Debug.Print strToTest
If InStr(strToTest, strTxtArray(k)) > 0 Then
ArrayTest = True
Exit For
Else
ArrayTest = False
End If
Next k
End Function

Public Sub DelPoliticalSpam()
Dim oInboxFolder As MAPIFolder
Dim obj As Object
Dim olApp As Outlook.Application
Dim objExpl As Outlook.Explorer
Dim strBodyHTML As String
Dim strTypeName As String
'On Error Resume Next
Set olApp = Application
Set objExpl = olApp.ActiveExplorer
Set oInboxFolder = ReturnFolder(strInbox1, olFolderInbox)

For Each obj In oInboxFolder.Items
strTypeName = TypeName(obj)
' Debug.Print strTypeName
If strTypeName = "MailItem" Then
strBodyHTML = obj.HTMLBody
If ArrayTest(strBodyHTML) Then
'MsgBox (strBodyHTML)
obj.Delete
End If
End If
Next obj
'return to inbox
objExpl.SelectFolder ReturnFolder(strInbox1, olFolderInbox)
Set obj = Nothing
Set oInboxFolder = Nothing

End Sub

 

[Diane Poremsky]

To run it as a rule - see

Outlook's Rules and Alerts: Run a Script

How to use Outlook's Rules Wizard Run a Script action to process messages using VBA. Using Run a Script rules will allow you to use actions not available in the Rules Wizard.

www.slipstick.com

This should work -
Public Sub DeleteSpamMessage(Item As Outlook.MailItem)
Dim strBodyHTML As String
strBodyHTML = item.HTMLBody
If ArrayTest(strBodyHTML) Then
'MsgBox (strBodyHTML)
item.Delete
End If
End Sub

 

[TedSch]

Thanks - I've been a fan of yours for a long time!
If I deleted the object/item in the for loop, I found that the previous version missed deleting about 1/2 because it shortened the collection. So, I added the items to be deleted to a new collection and then used a For to delete items in the new collection. That got them all.

Public Sub DelPoliticalSpam()
Dim oInboxFolder As MAPIFolder
Dim obj As Object
Dim olApp As Outlook.Application
Dim objExpl As Outlook.Explorer
Dim strBodyHTML As String
Dim strTypeName As String
Dim strSubject As String
Dim collItems As New Collection
On Error Resume Next
Set olApp = Application
Set objExpl = olApp.ActiveExplorer
Set oInboxFolder = ReturnFolder(strInbox1, olFolderInbox)

For Each obj In oInboxFolder.Items
strTypeName = TypeName(obj)
Debug.Print CStr(k) & ": " & strTypeName
If strTypeName = "MailItem" Then
strBodyHTML = obj.HTMLBody
strSubject = obj.Subject
If ArrayTest(strBodyHTML, strSubject) Then
collItems.Add obj
'obj.Delete
End If
End If
Next obj

For Each obj In collItems
strTypeName = TypeName(obj)
If strTypeName = "MailItem" Then
strBodyHTML = obj.HTMLBody
strSubject = obj.Subject
If ArrayTest(strBodyHTML, strSubject) Then
obj.Delete
End If
End If
Next obj

'return to inbox
objExpl.SelectFolder ReturnFolder(strInbox1, olFolderInbox)
Set obj = Nothing
Set oInboxFolder = Nothing
Set collItems = Nothing

End Sub

 

[Diane Poremsky]

I found that the previous version missed deleting about 1/2 because it shortened the collection.

Yeah, I didn't pick up on that when I looked at the macro. When deleting (or moving), you need to count backwards or it will skip every other message - if you have 5 and delete the first, message #2 is the former message #3.

For each works fine if you are flagging, categorizing - just not when moving and deleting.

Get the count then step back -

Dim intCount As Integer

For intCount = oInboxFolder.Items.Count To 1 Step -1
Set obj = oInboxFolder.Items.Item(intCount)
' do whatever
next