Thursday, April 14, 2011

Sort emails in outlook using a macro and a regular expression

On startup or manual execution (after macro is allowed to run), macro will go through all emails in the Inbox folder. For every email whose subject line matches the pattern in the regular expression, email will be moved into a subfolder where the title is the result of the pattern match. If said folder does not exist, it will be created.

Example: An email comes in with subject line "Review Case #12345.00", email will be moved into folder "Case #12345.00" (The code below does "Case #"+Pattern when creating a folder)

  • In Outlook -> Tools -> Macro -> Visual Basic Editor -> Paste code into ThisOutlookSession.
  • Change the regular expression to whatever pattern is required.

' Adapted from code by Bryce Pepper (
' I found here
' Searches for emails whose subject line contains a case number (ex. 12345.00)
' and files them in a subfolder with the case title (created if one does not exist)
'   Date:       Modified By:    Modification Made:
'   ----------------------------------------------------------------------
'   20110412    Joel Slowik     Added support to iterate through emails in main Inbox folder

Dim WithEvents objInboxItems As Outlook.Items
Dim objDestinationFolder As Outlook.MAPIFolder

Sub Application_Startup()

    Dim objNameSpace As Outlook.NameSpace
    Dim objInboxFolder As Outlook.MAPIFolder
    Set objNameSpace = Application.Session
    Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
    Set objDestinationFolder = objInboxFolder.Parent.Folders("Inbox")

    'Due to how vb script collections work, start at the top and work our way down
    'the list of emails:
    For count = objInboxFolder.Items.count To 1 Step -1
        Call objInboxItems_ItemAdd(objInboxFolder.Items.Item(count))
    Next count

End Sub

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

' This code is the actual rule.
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)

    Dim objProjectFolder As Outlook.MAPIFolder
    Dim folderName As String
    ' Search for email subjects that contain a case number
    ' Subject line must have the sequence of 5 numbers + . + 2 numbers (CPS case number syntax)
    Set objRegEx = CreateObject("VBScript.RegExp")
    objRegEx.Global = False
    objRegEx.Pattern = "[0-9]{5,5}\.?[0-9]{0,2}"
    Set colMatches = objRegEx.Execute(Item.Subject)
    'For all matches, move those matches to respective folder (create folder if it does not exist)
    If colMatches.count > 0 Then
        For Each myMatch In colMatches
            folderName = "Case #" & myMatch.Value
            If FolderExists(objDestinationFolder, folderName) Then
                Set objProjectFolder = objDestinationFolder.Folders(folderName)
                Set objProjectFolder = objDestinationFolder.Folders.Add(folderName)
            End If
            Item.Move objProjectFolder
    End If

    Set objProjectFolder = Nothing

End Sub

Function FolderExists(parentFolder As MAPIFolder, folderName As String)

    Set objRegEx = CreateObject("VBScript.RegExp")
    objRegEx.Global = False
    objRegEx.Pattern = folderName
    For Each F In parentFolder.Folders
        Set colMatches = objRegEx.Execute(F.Name)
        If colMatches.count > 0 Then
            FolderExists = True
            folderName = colMatches(0).Value
            Exit Function
        End If
    FolderExists = False
End Function


Chad Kimmell said...

Is there a way on this to move it to a folder that is already there. For example I have inbox > SubFolder_1 > Sub_SubFolder_1a.

No need to create, re-create, rename or anything else with the folders. Just move it to a folder's sub folder.

Chad Kimmell said...

Is there a way to move the mached items to a sub folder that is already in existance?