Create new folder for new sender name and move message into new folder

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.


This often asked question is answered here.

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