Custom VBA Email Filter

Ease of Use


Version tested with


Submitted by:



This code monitors your Outlook inbox for new additions, checks sender and recipient email addresses, and filters into inbox subfolders based on a predefined filter list stored in a CSV file. 


I currently use this code as a replacement for Outlook's rules and alerts. I rely heavily on email filtering to stay organized at work and Microsoft limits storage for rules and alerts to 256 kb (from what i understand). This is a workaround. 


instructions for use


Private WithEvents insp As Outlook.Inspectors '-------------------------------------------------------------------------------------------- ' Create an event handler to handle items being added to the inbox. See link below: ' https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/using-events-with-automation Private WithEvents Items As Outlook.Items ' ' Declare a public dictionary to load your email filtrs into (these can be defined directly ' in VB or loaded from a CSV or TXT file) Public oSORT As Dictionary '-------------------------------------------------------------------------------------------- Private Sub Application_Startup() '-------------------------------------------------------------------------------------------- ' Declare variables Dim olApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim sPATH As String '-------------------------------------------------------------------------------------------- '-------------------------------------------------------------------------------------------- ' If you're loading your email filters from a CSV file, create a filepath variable directing ' your code to the CSV. SortDict is a sub that loads two columns of CSV data into the public ' dictionary oSORT. It's important to load this on application startup and store as a public ' variable so the filters don't have to be reloaded every time a message is received. ' ' Define your items as the collection of inbox items and use the ItemAdd event to trigger ' your code when a new email is received. Set oSORT = CreateObject("Scripting.Dictionary") sPATH = "C:WorkDDEToolsOutlookFilters.csv" Call SortDict(oSORT, sPATH) Set olApp = Outlook.Application Set objNS = olApp.GetNamespace("MAPI") Set Items = objNS.GetDefaultFolder(olFolderInbox).Items '-------------------------------------------------------------------------------------------- End Sub Private Sub SortDict(ByRef oDICT As Dictionary, sPATH As String) '-------------------------------------------------------------------------------------------- ' This code takes an empty dictionary object and a csv file destination and loads the csv ' data into the dictionary. sPATH has to be the destination of a csv file including the ' filename, and the csv has to contain two columns of data. Dim sARR() As String Open sPATH For Input As #1 Do Until EOF(1) Line Input #1, sVAR sARR() = Split(sVAR, ",") oDICT(sARR(0)) = sARR(1) Loop Close #1 '-------------------------------------------------------------------------------------------- End Sub Private Sub Items_ItemAdd(ByVal Item As Object) On Error GoTo ErrorHandler '---------------------------------------------------------------------------------------------- ' Declare variables Dim Msg As Outlook.MailItem Dim oNAMESPACE As Outlook.NameSpace Dim oFOLDER As Outlook.Folder Dim sVAR As String, sTO As String, sFROM As String Dim sARR() As String Dim recips As Outlook.Recipients Dim recip As Outlook.Recipient Dim i As Integer, k As Integer '---------------------------------------------------------------------------------------------- '---------------------------------------------------------------------------------------------- ' - Confirm Item is an email ' - Retrieve sender's email address ' - Determine if sender's address is in a predefined filter list ' - Filter list is stored in a CSV file and read into a dictionary object. Left column of ' CSV file is a list of email addresses. Right column contains destination subfolders ' in the inbox. For multiple subfolder levels, each folder level must be specified and ' separated by semicolons. For example: 'Vendors;Walmart;Order Confirmations' ' - If sender's address is stored in the predefined list, move the incoming message to the ' destination folder ' - If sender's email isn't in filter list, iterate through recipients emails and perform ' the same check If TypeName(Item) = "MailItem" Then Set Msg = Item Set oNAMESPACE = Application.GetNamespace("MAPI") Set oFOLDER = oNAMESPACE.GetDefaultFolder(olFolderInbox) ' This code is incomplete. The sender's address is stored differently depending on whether the incoming ' email came from an exchange user or not. Haven't run into any bugs so far but I expect to. ' If Msg.SenderEmailType = "EX" Then sFROM = Msg.SenderEmailAddress ' Else ' Set pa = Msg.Sender.PropertyAccessor ' sFROM = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") ' End If If oSORT.Exists(sFROM) Then If InStr(1, oSORT(sFROM), ";", vbTextCompare) Then sARR() = Split(oSORT(sFROM), ";") For i = LBound(sARR) To UBound(sARR) Set oFOLDER = oFOLDER.Folders(sARR(i)) Next i Else Set oFOLDER = oFOLDER.Folders(oSORT(sFROM)) End If Msg.Move oFOLDER Set oFOLDER = Nothing Else Set recips = Msg.Recipients For Each recip In recips Set pa = recip.PropertyAccessor sTO = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001E") If oSORT.Exists(sTO) Then If InStr(1, oSORT(sTO), ";", vbTextCompare) Then sARR() = Split(oSORT(sTO), ";") For i = LBound(sARR) To UBound(sARR) Set oFOLDER = oFOLDER.Folders(sARR(i)) Next i Else Set oFOLDER = oFOLDER.Folders(oSORT(sTO)) End If Msg.Move oFOLDER Set oFOLDER = Nothing Exit For End If Next End If End If '---------------------------------------------------------------------------------------------- '---------------------------------------------------------------------------------------------- ' Error trapping and exit. ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit '---------------------------------------------------------------------------------------------- End Sub

How to use:

  1. Open Outlook 2013
  2. Navigate to File: Options: Customize Ribbon
  3. Under "Customize the Ribbon' dropdown, select "Main Tabs"
  4. Make sure "Developer" is checked in the list of Main Tabs
  5. Select OK
  6. From the ribbon, navigate to Developer: Visual Basic
  7. In the object explorer, expand "Microsoft Outlook Objects" folder and double click "ThisOutlookSession"
  8. From the menu bar, select Tools: References
  9. Enable "Microsoft Outlook 15.0 Object Library"
  10. Paste the code below into the VB Editor
  11. Create a .CSV file and populate with your email filters (see the comments under Sub 'Items_ItemAdd' for instructions on how to write these filter rules)
  12. Under the sub 'Application_Startup' change the file path 'C:WorkDDEToolsOutlookFilters.csv' to the location of your CSV file
  13. Close VB
  14. Close Outlook and save the changes to your VB code
  15. Reopen Outlook

Test the code:

  1. Create a "Test" subfolder in your Outlook inbox
  2. Update your CSV file to contain one of your email addresses and have it filtered into your "Test" Subfolder
  3. Send yourself an email from the filtered address and confirm that the incoming email gets sorted into your "Test" Subfolder

Sample File:

No Attachment 

Approved by Jacob Hilderbrand

This entry has been viewed 17 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express