Background

I'd like to have Outlook 2010 automatically move e-mails into folders designated by the person's name. For example:

1. Click Rules
2. Click Manage Rules & Alerts
3. Click New Rule
4. Select "Move messages from someone to a folder"
5. Click Next

The following dialog is shown:

Problem

The next part usually looks as follows:

1. Click people or public group
2. Select the desired person
3. Click specified
4. Select the desired folder

Question

How would you automate those problematic manual tasks? Here's the logic for the new rule I'd like to create:

1. Receive a new message.
2. Extract the name of the sender.
3. If it does not exist, create a new folder under Inbox
4. Move the new message into the folder assigned to that person's name

I think this will require a VBA macro.

Related Links

• http://www.experts-exchange.com/Software/Office_Productivity/Groupware/Outlook/A_420-Extending-Outlook-Rules-via-Scripting.html
• http://msdn.microsoft.com/en-us/library/office/ee814735.aspx
• http://msdn.microsoft.com/en-us/library/office/ee814736.aspx
• https://stackoverflow.com/questions/11263483/how-do-i-trigger-a-macro-to-run-after-a-new-mail-is-received-in-outlook
• http://en.kioskea.net/faq/6174-outlook-a-macro-to-create-folders
• http://blogs.iis.net/robert_mcmurray/archive/2010/02/25/outlook-macros-part-1-moving-emails-into-personal-folders.aspx

Update #1

The code might resemble something like:

Public WithEvents myOlApp As Outlook.Application

Sub Initialize_handler()
    Set myOlApp = CreateObject("Outlook.Application")
End Sub

Private Sub myOlApp_NewMail()
    Dim myInbox As Outlook.MAPIFolder
    Dim myItem As Outlook.MailItem

    Set myInbox = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set mySenderName = myItem.SenderName

    On Error GoTo ErrorHandler
    Set myDestinationFolder = myInbox.Folders.Add(mySenderName, olFolderInbox)

    Set myItems = myInbox.Items
    Set myItem = myItems.Find("[SenderName] = " & mySenderName)
    myItem.Move myDestinationFolder

ErrorHandler:
    Resume Next
End Sub

Update #2

Split the code as follows:

Sent a test message and nothing happened. The instructions for actually triggering a message when a new message arrives are a little light on details (for example, no mention is made regarding ThisOutlookSession and how to use it).

Thank you.

Solution 1:

This often asked question is answered here.

https://web.archive.org/web/20131024034054/http://www.jpsoftwaretech.com/automatically-triage-emails-by-sender-name/

Uses ItemAdd to do what Newmail, now NewMailEx, would do.

In the ThisOutlookSesion module

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

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

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

Solution 2:

I'd forget using rules completely and instead make a VBA macro that's attached to the NewMail event that will create a folder (using the Folders.Add method) based on the SenderName property, and then move it there with the MailItem's Move method.