How I used VBA to filter spam, Part 2 

Part 1, 2

I was finally able to finish this. Below I have included the code that will filter a great deal of SPAM from my Inbox in MS Outlook 2003. I modified the existing VBAProject.OTM project to create a module name FolderFilter.

Here are the directions to enable RegEx in VBA.

  1. In the code editor, select menu item Tools > References.
  2. Check item Microsoft VBScript Regular Expressions.

The code: 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

' Making pattern global
Dim pattern As String
 
' Initialization code is here
Sub init()
pattern = "src=""cid:"
Debug.Print "Looking for '" & pattern & "'"
 
End Sub
 
' Filtering of matched spam happens here
Sub filterSpam()
FolderFilter.init
 
' Setting up Inbox variable
Dim filterFolder As Outlook.MAPIFolder
Set filterFolder = ThisOutlookSession.Session.GetDefaultFolder(olFolderInbox)
 
' Setting up Junk Mail variable
Dim destFolder As Outlook.MAPIFolder
Set destFolder = ThisOutlookSession.Session.GetDefaultFolder(olFolderJunk)
 
Debug.Print "Moving matches to " & destFolder.Name
 
Dim o As Object
Dim mail As mailItem
Dim items As items
 
' Grabbing items from the folder to filter
Set items = filterFolder.items
 
' Simple infinite loop
Do While True
Set mail = items.GetNext
 
' When there are no more items we exit the loop and jump to Go label
If mail Is Nothing Then
GoTo Go
End If
 
' Moves the mail to the destFolder if it matches the pattern
If findMatch(pattern, mail.HTMLBody) = 1 Then
Set o = mail.Move(destFolder)
Debug.Print "Removing message '" & mail.Subject & "'"
End If
 
Loop
Go:
 
Debug.Print "Finished Filtering"
 
End Sub
 
' Code from http://www.markcarter.me.uk/computing/vba/regex.html
' gave me insight on how to use RegExp
Function findMatch(pattern As String, content As String)
Dim re As RegExp
Set re = New RegExp
 
' Setting the return to 0 initially
findMatch = 0
 
re.pattern = pattern
re.Global = False
re.IgnoreCase = True
re.Multiline = True
 
Dim matches As MatchCollection
Set matches = re.Execute(content)
 
Dim match As match
For Each match In matches
' Setting the return to 1
findMatch = 1
GoTo Done
Next
 
Done:
 
End Function

This code will move any mail that contains the pattern “src=”cid:” to the junk folder. Enjoy! I hope it can help someone out other than me.