Filtering emails in Outlook


Filtering emails by different authors is key part of the processing stage of electronic discovery. Outlook expert Diane Poremsky has posted a very helpful macro to slipstick.com which will automatically move all of the emails you select in Outlook into different subfolders - one subfolder for each sender.

This can save you some time and avoid doing some sorting, copying, and new folder creation. In Outlook 2016 just go to the Developer tab . . . Visual Basic, and then right click on 'ThisOutlookSession' in the Project section and insert a new module. Save and close. Select the emails you need to process and then go back to the Developer tab and select the macro. New folders for each sender will be automatically created.

Public Sub MoveSelectedMessages()

Dim objOutlook As Outlook.Application

Dim objNamespace As Outlook.NameSpace

Dim objDestFolder As Outlook.MAPIFolder

Dim objSourceFolder As Outlook.Folder

Dim currentExplorer As Explorer

Dim Selection As Selection

Dim obj As Object

Dim objVariant As Variant

Dim lngMovedItems As Long

Dim intCount As Integer

Dim intDateDiff As Integer

Dim strDestFolder As String

Set objOutlook = Application

Set objNamespace = objOutlook.GetNamespace("MAPI")

Set currentExplorer = objOutlook.ActiveExplorer

Set Selection = currentExplorer.Selection

Set objSourceFolder = currentExplorer.CurrentFolder

For Each obj In Selection

Set objVariant = obj

If objVariant.Class = olMail Then

intDateDiff = DateDiff("d", objVariant.SentOn, Now)

' I'm using 40 days, adjust as needed.

If intDateDiff > 40 Then

sSenderName = objVariant.SentOnBehalfOfName

If sSenderName = ";" Then

sSenderName = objVariant.SenderName

End If

On Error Resume Next

' Use These lines if the destination folder is not a subfolder of the current folder

' Dim objInbox As Outlook.MAPIFolder

' Set objInbox = objNamespace.Folders("alias@domain.com"). _

Folders("Inbox") ' or whereever the folder is

' Set objDestFolder = objInbox.Folders(sSenderName)

Set objDestFolder = objSourceFolder.Folders(sSenderName)

If objDestFolder Is Nothing Then

Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)

End If

objVariant.Move objDestFolder

'count the # of items moved

lngMovedItems = lngMovedItems + 1

Set objDestFolder = Nothing

End If

End If

Err.Clear

Next

' Display the number of items that were moved.

MsgBox "Moved " & lngMovedItems & " messages(s)."

Set currentExplorer = Nothing

Set obj = Nothing

Set Selection = Nothing

Set objOutlook = Nothing

Set objNamespace = Nothing

Set objSourceFolder = Nothing

End Sub