Automatically triage emails by sender name
September 14, 2009 • JP • 11 Comments • Rate This Article
If you want to sort incoming emails by sender, a popular way to sort them is to move them to individual subfolders depending on the sender's name. I've written some event code based on Stock Outlook VBA Event Code that can do that for you programmatically.
It starts out with the following declaration:
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' set object reference to default Inbox
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Items is declared using the WithEvents keyword, indicating that we are going to create an event handler of type Outlook.Items.
The ItemAdd Event fires when new items (of any type) are added to the referenced folder. We'll check if a MailItem has been added, and if so, we'll move the email to a subfolder of the default Inbox with the same name as the sender. If the subfolder doesn't exist, it is created before moving the message.
' fires when new item added to default Inbox
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
' don't do anything for non-Mailitems
If TypeName(item) <> "MailItem" Then GoTo ProgramExit
Set Msg = item
' move received email to target folder based on sender name
senderName = Msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = _
objNS.GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
You'll also need to grab the CheckForFolder and CreateSubFolder procedures, found at Look for and create folders programmatically.
Note that this event handler assumes that you want the sender name folders to be placed one level below the default Inbox. If you don't want that, you'll need to edit the CheckForFolder and CreateSubFolder procedures, as well as Items_ItemAdd, to point to the correct folder and level.
Outlook ·
Rate This Article:
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Why you shouldn't use Excel's macro recorder to learn VBA
Next Post: Sharing email addresses in Outlook and an approach to problem-solving
Thank you for the very useful code!
Thanks for your code. I am new to VBA for the last month and a half but am picking it up nicely. I am just starting to make my foray into Outlook and could use some help modifying your code to my needs.
Instead of the code running anytime a new item is added to the reference folder, I would like to tell it when to run. I currently am using rules in 2007 to move emails from members of a select department in our company into their own personal folders. I have so many of these now, that I do not see them unless I scroll down thru my subfolders. A more ideal situation is to have them all come into one folder labeled with the department name. On Friday, I would like to run the macro to move any of these messages that are read to the folder of that sender. This way I can manage my unread and todo items from the sender before moving the items.
Any thoughts?
Thanks
Adam
Adam –
Try this. It lets you pick a folder and then loops through it, moving the items based on sender name into their own folders one level below the default Inbox. If the folder doesn't exist, it is created. You'll also need to grab the CheckForFolder and CreateSubFolder procedures, found at Look for and create folders programmatically.
Dim fldr As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
Set fldr = GetNS(GetOutlookApp).PickFolder
If fldr Is Nothing Then GoTo ErrorHandler
For Each msg In fldr.Items
' move received email to target folder based on sender name
senderName = msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set targetFolder = _
GetNS(GetOutlookApp).GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
msg.Move targetFolder
Next msg
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetOutlookApp() As Outlook.Application
' returns reference to native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) _
As Outlook.NameSpace
' returns a Namespace Object to access MAPIFolder objects
Set GetNS = app.GetNamespace("MAPI")
End Function
So I've been looking for a macro as well that will run as soon as an email is marked as read. I'm trying to catch emails from a specific sender. So, say the person emails me, i click the email to read it, it shows in the reading pane, and i click away – therefore marking it as read, it would then be moved to a folder called "personal". I currently have a manual macro that i have to click to run, but I can't seem to grab the sender's name or email address. We are on an exchange server with outlook 2007. Here's what i have… *I edited this line 'If senderName = "Person's name" Then' for anonymity* Person's name is either address or the name associated with the contact record. Such as John Doe johndoe@example.com
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim senderName As String
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Old Mail -Beeson").Folders("Personal")
'Assume this is a mail folder
If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If
senderName = msg.senderName
If senderName = "Person's name" Then
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.UnRead = False
objItem.Move objFolder
End If
End If
Next
Else
'for Sender name
End If
Set objItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
End Sub
Hi Jeremy-
Thank you so much for the code. I finally had some time to give it a run thru, and it appears to work initially, though I get an error 13 – type mismatch. Any thoughts?
Here is what I have (I added the '————- for better visibility)
Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
'——————————————————————————————-
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
'————————————-
Public Sub MoveIt()
On Error GoTo ErrorHandler
Dim fldr As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
Set fldr = GetNS(GetOutlookApp).PickFolder
If fldr Is Nothing Then GoTo ErrorHandler
For Each msg In fldr.Items
' move received email to target folder based on sender name
senderName = msg.senderName
If CheckForFolder(senderName) = False Then ' Folder doesn't exist
Set targetFolder = CreateSubFolder(senderName)
Else
Set targetFolder = _
GetNS(GetOutlookApp).GetDefaultFolder(olFolderInbox).Folders(senderName)
End If
msg.Move targetFolder
Next msg
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " – " & Err.Description
Resume ProgramExit
End Sub
'——————————————————————-
Function GetOutlookApp() As Outlook.Application
' returns reference to native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
'————————————————————————-
Function GetNS(ByRef app As Outlook.Application) _
As Outlook.NameSpace
' returns a Namespace Object to access MAPIFolder objects
Set GetNS = app.GetNamespace("MAPI")
End Function
Thanks
Adam
Jeremy –
This code will automatically move emails from a given sender to a subfolder called "personal" whenever an email from that sender is read. Edit as needed. Note that opening emails will also mark them as read.
Private WithEvents msg As Outlook.MailItem
Private Sub Application_Startup()
Set objExplorer = Application.ActiveExplorer
End Sub
Private Sub msg_PropertyChange(ByVal Name As String)
Dim myFolder As Outlook.MAPIFolder
If msg.UnRead = False Then
If msg.senderName = "the name you are looking for" Then
Set myFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("personal")
msg.Move myFolder
End If
End If
End Sub
Private Sub objExplorer_SelectionChange()
If objExplorer.CurrentFolder.DefaultItemType = olMailItem Then
If objExplorer.Selection.Count > 0 Then
Set msg = objExplorer.Selection(1)
End If
End If
End Sub
Thank you! One small problem with the code, I get this error:
Run-Time error '459':
Object or class does not support the set of events
It then points to this line of code -> Set msg = objExplorer.Selection(1)
I'm not sure whats its looking for at Run-time that's not available. That's a part of the code I'm not familiar with. I did change the name of the person in the code.
I wish i could edit my post. Ok, I figured out the problem, which led me to another.
Set myFolder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("personal")
This program works fine if i have a folder inside my Inbox called personal. However, i have it inside a folder stored and backup up on our network called Old Mail its a .pst file. So, i have a "Personal" folder inside of "Old Mail". So I edited the line to this:
Set myFolder = Outlook.Session.GetDefaultFolder("Old Mail").Folders("Personal")
Now i have a run-time error 13 i think it was. The original code i posted to find this folder worked.
Set objFolder = objNS.Folders("Old Mail -Beeson").Folders("Personal")
I have since renamed the folder to simply "Old Mail"
Can it not find the folder because of the ".GetDefaultFolder"?
That's right. Try
Set objFolder = objNS.Folders("Old Mail").Folders("Personal")
Jeremy- you said that you fixed the Runtime error- I am getting an error 13 on this line:
Set msg = objExplorer.Selection(1)
what did you change??
I fixed the Run-Time error '459' not the 13. I couldn't get the code to work despite making the changes. I don't need it anymore anyway. Sorry I couldn't help. It seemed to work if the folder you are putting the mail in is a subfolder within the "inbox".