An Experiment with Outlook Mail Filtering using VBA
 
 

 Having had lots of fun in the past writing VB to get under the covers of various Office applications, figured it can't be too hard to write custom mail filters for Outlook.  So I spent a few hours to find out what is involved. 

I do not claim that these results are sophisticated, or complex.  I don't even claim that what's here is very useful as is.  The idea is that since I spent a couple of hours to get this far, you, a reasonably intelligent programmer type, can take what's here and accomplish your custom mail filtering task in T  minus a couple of hours, where T is the time you would have otherwise spent. 

Off we go:

I wound up writing two functionally similar versions of the mail filter.  The first version used the objects that are built-in to Outlook, and made available when you add a reference in your VB project to the "Microsoft Outlook 9.0 Object Library".  I found that this version had certain shortcomings, such as I could not find a way to get access to SMTP headers, and I found that the HTMLBody property was not always populated with HTML as one would expect.  The second version of the filter used MAPI objects which are available when you add a reference to the "Microsoft CDO 1.21 Library".  Both versions are below, the second one being shown first.

To use this code, in Outlook Tools->Macro->Visual Basic Editor, paste the code below into the built-in project called "ThisOutlookSession".   Use Tools->References in the VB editor to select libraries required as noted above.

To digitally sign the VBA so that Outlook will start without issuing that pesky macro warning:

  1. Create a personal digital signature with selfcert.exe which is included as part of Office, but perhaps is not installed by default.
  2. In the VBA editor, under Tools->Digital Signature, select the signature, save, close.
  3. Answer the prompt on next launch to enable macros, and always trust macros created by yourself. 

MSDN documentation provided with VB6, and the Outlook programmer docs provided with Office were the essential references.  Parts of the code below were cribbed directly from those references.

Here's the code.  Have fun!

 

'One Outlook object to catch events
Dim WithEvents objInboxItems As Outlook.Items
'The rest is CDO stuff:
Dim objSession As MAPI.Session
Dim objInbox As MAPI.Folder
Dim objJunk As MAPI.Folder

'This causes the filtering to start when we launch Outlook.
Private Sub Application_Startup()
    StartVBAFiltering
End Sub

' Run this code to start things up.
Sub StartVBAFiltering()
    Dim objNameSpace As Outlook.NameSpace
    Dim objInboxFolder As Outlook.MAPIFolder
    'Instantiate Outlook objInboxItems.. this is the thing that gets the
    ' new item events.
    Set objNameSpace = Application.Session
    Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
    Set objInboxItems = objInboxFolder.Items
    
    'Initialize the CDO stuff.
    Set objSession = CreateObject("MAPI.Session")
    'Assume there is an existing session to connect to:
    objSession.Logon newSession:=False
    Set objInbox = objSession.Inbox
    'Of course the Junk Mail folder is assumed to exist in advance:
    Set objJunk = objInbox.Folders.Item("Junk Mail")
    
    'Run filters once at startup:
    CDOfilterUnreadItems
End Sub

' Run this code to stop.
Sub StopVBAFiltering()
   Set objInboxItems = Nothing
End Sub

'the event handler for ItemAdd
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    CDOfilterUnreadItems
End Sub
'Using CDO instead of the Outlook objects seems to give slighly better
'results.  The data is more raw (ie. no fine categorizations such as HTMLBody)
'but seems more complete (ie I can get access to the message envelope).
'The VB reference selected to enable the use of the MAPI objects was called
'"Microsoft CDO 1.21 Library"
'Note that every time invoked we will look at all unread messages, so
'some messages will be filtered more than once.
Sub CDOfilterUnreadItems()
    Dim objMessages As MAPI.Messages
    Dim objMessage As MAPI.Message
    On Error GoTo CDO_error
    Set objMessages = objInbox.Messages
    For Each objMessage In objMessages
        If objMessage.UnRead Then
            cdo_filter objMessage
        End If
    Next
    Exit Sub
CDO_error:
    MsgBox "Error in CDOfilterUnreadItems."
End Sub

Private Sub cdo_filter(msg As MAPI.Message)
    cdo_dump_to_file msg
    ' Add CDO filter procs here
    cdo_TextFindNMove msg, "I send you this file in order to have your advice", objJunk
    cdo_TextFindNMove msg, "Connects Up To 100 Participants!", objJunk
End Sub

' Write interesting fields from a message to a disk file
Private Sub cdo_dump_to_file(msg As MAPI.Message)
    Dim report As String
    Dim fields_coll As MAPI.Fields
    Dim my_field As MAPI.Field
    Dim my_address As MAPI.AddressEntry
    Dim DumpFile
    Set fields_coll = msg.Fields
    report = "***************mail record starts here******************" + vbCrLf
    'Referencing things that are undefined will cause errors, so:
    On Error GoTo next1
    Set my_field = fields_coll.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS)
    report = report + "**Message Header:**" + vbCrLf + my_field.Value + vbCrLf
next1:
    On Error GoTo next2
    If msg.Sent Then
        report = report + "**Sender**: " + vbCrLf + msg.Sender.Address + vbCrLf
    End If
next2:
    'todo: add logging for more fields
    report = report + "**Subject**: " + vbCrLf + msg.subject + vbCrLf
    report = report + "**Text**: " + vbCrLf + msg.text + vbCrLf
 
    'Note that we will often get more than one message logged per file..
    DumpFile = "C:\CDO_MAIL_DUMP_" & Format(Date, "ddmmyyyy") & "_" & Format(time, "hhmmss") & ".txt"
    Open DumpFile For Append As #1
    Print #1, report
    Close #1
End Sub

' Look for a text string in a message body and if found, move the message to dest_folder
Private Sub cdo_TextFindNMove(msg As MAPI.Message, target As String, dest_folder As MAPI.Folder)
    Dim Loc As Long
    Loc = InStr(1, msg.text, target, vbTextCompare)
    If Loc Then
        msg.MoveTo (dest_folder.ID)
    End If
End Sub
This is the original version using Outlook objects: 
Dim WithEvents objInboxItems As Outlook.Items
'Dim objDestinationFolder As Outlook.MAPIFolder

'This causes the filtering to startup when we launch Outlook.
Private Sub Application_Startup()
   StartVBAFiltering
End Sub

' Run this code to start your rule.
Sub StartVBAFiltering()
   Dim objNameSpace As Outlook.NameSpace
   Dim objInboxFolder As Outlook.MAPIFolder
   Set objNameSpace = Application.Session
   Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
   Set objInboxItems = objInboxFolder.Items
   'Set objDestinationFolder = objInboxFolder.Folders("Temp")
End Sub

' Run this code to stop your rule.
Sub StopVBAFiltering()
   Set objInboxItems = Nothing
End Sub

' This code is the actual rule.
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
    HTMLFindNReplace Item, "myemail@cs.washington.edu" 'prevent a widely used method of address validation
    BodyFindNMove Item, "I send you this file in order to have your advic" 'code red still popping up..
End Sub

'Search for the target string in the Body part of the item.
'if found, move the item to the "Junk Mail" folder (which is assumed to exist in advance),
'and dump the mail to a text file.
Private Sub BodyFindNMove(myItem As Object, target As String)
    Dim Loc As Long
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    
    Loc = InStr(1, myItem.Body, target, vbTextCompare)
    If Loc Then
        DumpItemToFile myItem
        Set myNameSpace = Application.Session
        Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
        Set myDestFolder = myInbox.Folders("Junk Mail")
        'MsgBox ("Warning! The target string: " + target + " was found in the message with " + _
        '    "subject: " + myItem.subject + "  The item will be moved to the junk mail folder.")
        myItem.Move myDestFolder
    End If
End Sub

'Search for the target string in the HTMLBody part of Item.  If found,
'warn, replace with a string of descriptive text, and dump the mail to a text file.
Private Sub HTMLFindNReplace(myItem As Object, target As String)
    Dim Loc As Long
    Loc = InStr(1, myItem.HTMLBody, target, vbTextCompare)
    If Loc Then
        DumpItemToFile myItem
        MsgBox ("Warning! The target string: " + target + " was found in the message with " + _
            "subject: " + myItem.subject + "  The string will be replaced.")
        myItem.HTMLBody = Replace(myItem.HTMLBody, target, "***A string here was replaced by your friendly VBA mailfilter***")
        myItem.Save
    End If
End Sub

'dump some of the interesting fields of a mail item to a text file at C:\
Private Sub DumpItemToFile(Item As Object)
    Dim report As String
    Dim DumpFile

   report = ""
   report = report + "**To**: " + vbCrLf + Item.To + vbCrLf
   report = report + "**SenderName**: " + vbCrLf + Item.SenderName + vbCrLf
   report = report + "**Subject**: " + vbCrLf + Item.subject + vbCrLf
   report = report + "**SentOnBehalfOfName**: " + vbCrLf + Item.SentOnBehalfOfName + vbCrLf
   report = report + "**ReplyRecipientNames**: " + vbCrLf + Item.ReplyRecipientNames + vbCrLf
   report = report + "**ReceivedOnBehalfOfName**: " + vbCrLf + Item.ReceivedOnBehalfOfName + vbCrLf
   report = report + "**ReceivedByName**: " + vbCrLf + Item.ReceivedByName + vbCrLf
   report = report + "**ReceivedByEntryID**: " + vbCrLf + Item.ReceivedByEntryID + vbCrLf
   report = report + "**OutlookVersion**: " + vbCrLf + Item.OutlookVersion + vbCrLf
   report = report + "**MessageClass**: " + vbCrLf + Item.MessageClass + vbCrLf
   report = report + "**HTMLBody**: " + vbCrLf + Item.HTMLBody + vbCrLf
   report = report + "**EntryID**: " + vbCrLf + Item.EntryID + vbCrLf
   report = report + "**ConversationTopic**: " + vbCrLf + Item.ConversationTopic + vbCrLf
   report = report + "**Companies**: " + vbCrLf + Item.Companies + vbCrLf
   report = report + "**CC**: " + vbCrLf + Item.CC + vbCrLf
   report = report + "**Categories**: " + vbCrLf + Item.Categories + vbCrLf
   report = report + "**BCC**: " + vbCrLf + Item.BCC + vbCrLf
   report = report + "**Body**: " + vbCrLf + Item.Body + vbCrLf
    
    DumpFile = "C:\MAIL_DUMP_" & Format(Date, "ddmmyyyy") & "_" & Format(time, "hhmmss") & ".txt"
    Open DumpFile For Output As #1
    Print #1, report
    Close #1
End Sub

Back to my home page