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 WithEvents Items As Outlook.Items
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.
Private Sub Items_ItemAdd(ByVal item As Object)
' 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.
About JP
13 Comments:
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.
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 FunctionSo 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
Sub MoveToArchive() 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 SubHi 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 objExplorer As Outlook.Explorer 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 SubThank 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".
This looks to be a lovely bit of code, but I have struggled to get it working for a couple days now. Correct me if I'm wrong, but after you compile and save it, it should show up in the macros list in Outlook? I have made myself a certificate and verified that other macros will run, but this one still refuses to show up. Sorry about the vauge problem description, I'm (very) new to VBA.
Event handlers run automatically, they should not appear in the list of macros when you press Alt+F8.
After pasting the code into the ThisOutlookSession module (see Where do I put my Outlook code) you must restart Outlook. Also, if you make any changes to the code, you must restart Outlook. See My Outlook code won't run to make sure you've completed all the necessary steps to ensure your code will run.
Also, keep in mind that it may appear your code isn't running. After restarting Outlook, set a breakpoint at the start of the code and then do something to trigger the event handler (drag and drop an email into the default Inbox) and then you can step through the code to make sure it is doing what you want.