Last reviewed on April 19, 2015   —  19 Comments

I'm using your Move aged email macro. I tweaked it a little so that instead of moving all of the mail to one folder I have it going to folders based on the sender's name. Now what I would like to do is, when the macro looks for the sender's name if there is not a folder, one will be created.

Create subfoldersThe following two macros will move the messages to a folder named for the sender, creating the folder if it does not exist. The first macro works on selected messages in any folder, moving the messages to subfolders under the current folder. The second macro is the one Joel tweaked and needed help with the code to create the folder.

Creating a new folder is just a couple of lines. By using On Error Resume Next, you can set the folder variable and next line runs if an error is encountered. This is important because an error will be triggered when you try to set the destination folder to a folder that doesn't exist. The next lines tell Outlook to create the folder if it doesn't exist.

On Error Resume Next
Set objDestFolder = objSourceFolder.Folders(sSenderName)
 
If objDestFolder Is Nothing Then
    Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
End If

File selected messages by sender's name

While I'm not a big fan of filing messages in hundreds of folders, I can see the value in filing some messages. This version of the macros works on the selected message(s) and creates a subfolder in the current folder.

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 > 4 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

File aged messages by sender's name

This version of the macro moves messages to an Inbox subfolder named for the sender. It looks for the display name, and if a folder does not exist, it creates it. If the sender uses different email clients, the messages may be filed in several folders. Using the sender's email address would eliminate this problem, but make it harder to know who each folder is for.

Sub MoveAgedMail()
  Dim objOutlook As Outlook.Application
  Dim objNamespace As Outlook.NameSpace
  Dim objSourceFolder As Outlook.MAPIFolder
  Dim objDestFolder As Outlook.MAPIFolder
  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 objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
      
  For intCount = objSourceFolder.Items.Count To 1 Step -1
    Set objVariant = objSourceFolder.Items.Item(intCount)
    DoEvents

    If objVariant.Class = olMail Then
       intDateDiff = DateDiff("d", objVariant.SentOn, Now)
        ' I'm using 40 days, adjust as needed.
       If intDateDiff > 40 Then
       ' use your datafile name and each folder in the path
       ' the example uses an email address because Outlook 2010
       ' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName

If sSenderName = ";" Then
  sSenderName = objVariant.SenderName
  
End If

On Error Resume Next

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
  Next
  
' Display the number of items that were moved.
  MsgBox "Moved " & lngMovedItems & " messages(s)."
    
  Set objOutlook = Nothing
  Set objNamespace = Nothing
  Set objSourceFolder = Nothing

End Sub

File by Year

This code snippet shows how to file messages by year, moving only those messages that are older than a year.

Dim intYear As String

      If objVariant.Class = olMail Then
        intDateDiff = DateDiff("d", objVariant.ReceivedTime, Date)
        Debug.Print Date & " " & intDateDiff
        
       If intDateDiff > 365 Then
         intYear = Year(objVariant.ReceivedTime)
         Debug.Print objVariant.Subject & "--" & intYear
 
   On Error Resume Next
  
   Set objDestFolder = objSourceFolder.Folders(intYear)
'  Debug.Print objDestFolder
   If objDestFolder Is Nothing Then
    Set objDestFolder = objSourceFolder.Folders.Add(intYear)
       End If
            objVariant.Move objDestFolder
            'count the # of items moved
            lngMovedItems = lngMovedItems + 1
            Set objDestFolder = Nothing
         
       End If
        Err.Clear
      End If
    Next

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

  1. Right click on Project1 and choose Insert > Module
  2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor

Comments

  1. Oscar Perez says

    Your macro "File aged messages by sender's name" turned out to be the perfect code I needed. I'm not a programmer, but sometime I can figure out things and make them work for my needs. After using your code, it seems that the sender's name sometimes came across as just the First Name and others as First Last Name and other times as First Initial Last Name, so I have 2-3 folders for the same person. I thought if I could use a data dictionary, that I would have to manually update, where if the sender's name was different, but the email address was the same, I could file those emails under the same folder. Do you think that's possible and would you have some example code?

  2. Oscar says

    Diane, as previously posted this script was just the perfect code that I needed, but first time around it only moved about half of my emails and took a very long time. I have been trying to move the other half of my emails and it doesn’t seem to do anything. I don’t know VBA, but I know enough about coding to make me dangerous, so I added a debug.print right after the DoEvents to show the if the objVariant.Class was equal to olMail and it shows objVariant.Class to be equal to 53 or 54 and olMail to be equal to 43 for the remaining emails. I don’t know what does numbers mean or where to look. Can you please help?

  3. jonathandire says

    Hi Diane,

    I am trying to use the above method to prompt the user to save the email to folder and then send. (the save & send button is disabled for sharedinboxes here).

    The code I've gotten so far is:

    Private Sub Application_ItemSend(ByVal Item As Object, _
    Cancel As Boolean)
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolder = objNS.PickFolder
    If TypeName(objFolder) "Nothing" And _
    IsInDefaultStore(objFolder) Then
    Set Item.SaveSentMessageFolder = objFolder
    End If
    Set objFolder = Nothing
    Set objNS = Nothing
    End Sub

    Public Function IsInDefaultStore(objOL As Object) As Boolean
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objInbox As Outlook.MAPIFolder
    On Error Resume Next
    Set objApp = CreateObject("Outlook.Application")
    Set objNS = objApp.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    Select Case objOL.Class
    Case olFolder
    If objOL.StoreID = objInbox.StoreID Then
    IsInDefaultStore = True
    End If
    Case olAppointment, olContact, olDistributionList, _
    olJournal, olMail, olNote, olPost, olTask
    If objOL.Parent.StoreID = objInbox.StoreID Then
    IsInDefaultStore = True
    End If
    Case Else
    MsgBox "This function isn't designed to work " & _
    "with " & TypeName(objOL) & _
    " items and will return False.", _
    , "IsInDefaultStore"
    End Select
    Set objApp = Nothing
    Set objNS = Nothing
    Set objInbox = Nothing
    End Function

    The only problem I have is, that is it prompts the user to save to a folder, for every email.

    I wanted to use a button just like save and send to only provide the option when clicked and then send the email once the folder is selected.

    Could you please help if you get a chance?

    • Diane Poremsky says

      This:
      Private Sub Application_ItemSend(ByVal Item As Object, _
      Cancel As Boolean)

      tells it to check when you send every message. If you want to check only when you press a special Send button, you won't use an itemsend macro.

      if you want ot use an itemsend macro, you need to use an if statement to apply it to certain messages.

  4. Z Gansad says

    Hi,
    Is there a macro to reset the actions done by this VBA?
    The 2nd script really worked too well .. I just realized I created 200+ folders from all the senders :(

    Thanks

    • Diane Poremsky says

      :) I did the same thing when I tested it on my mailbox. I don't know why people think filing mail like that is better than using instant search. :) I don't have a macro, but a search folder should find everything then use the move to folder command.

      I think i have a macro around here to delete the folders, but you can drag them into each other then delete the last one.

  5. Tümer says

    Dear Diane
    thank you for the macros and web pages. ı try <Macro to file Outlook email by sender's display name - File selected messages by sender's name< ı use gmail with outlook ıts work perfect but when ı use for company e-mail its not work. ıs there somethink ı miss ? (company mail exchange server).
    would you help me ? and how can ı change the code for inbox to sent items folder

    • Diane PoremskyDiane Poremsky says

      What happens when you use it on the work account? As long as you are using the display name, it should work. (I tested it on an exchange mailbox.) Filing by email address won't work very well with messages from coworkers, because the exchange address is long and ugly.

    • Diane PoremskyDiane Poremsky says

      Oh, and for the sent folder, the first macro works on the selected folder, The second one uses this line to set the folder:
      Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

      change the folder to olFolderSentMail.

  6. Mitch Mitchell says

    I am encouraged by your code but it results in an error on the sSender as not having definition. Tried Dimming as String(same result) and Object(No error but no files moved either). Am I missing something?

    • Diane PoremskyDiane Poremsky says

      it should be dimmed as a string. do any messages meet the condition in the IF statement - ie, received 40 days ago?

  7. Tümer says

    Dear Diane,

    first of all thank you for reply :) as actually require when ı sent an e-mail sent mail has to move ==> 2015 -- "X person name folder " ı try several times but I cant do it. when ı saw your code I try and guess maybe ı change to use for sentitem folder and make sub folders for when ı use it.

    sorry I made mistake giving wrong macro code name: "Sub MoveAgedMail() " when ı use Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox) macro says " move 0 mail" but when ı change to olfolderSentitems result is " run time error

    • Diane PoremskyDiane Poremsky says

      in the sent folder, you are the sender. You'd need to use the To field, but it won't work correctly when you send to multiple recipients. Anyway, the correct folder name is olFolderSentMail sorry about that.

  8. Zach says

    Is it possible to tweak this so that it selects and files an entire conversation string based off the original sender?

    Example - Brittany W. send first email and receives 5 replies. I would like to select the conversation using this code and have it file under Brittany W. or create a new folder named Brittany W. if one does not exist just as this does for single emails.

    • Diane PoremskyDiane Poremsky says

      I found a sample at msdn to tweak. My changes are kinda half working - the folder is created and items copied, not moved.
      The original code is here: https://code.msdn.microsoft.com/office/Outlook-2010-Manipulate-64fead5e

      Public Sub GetConverstationInformation()
      Dim host As Outlook.Application
      Set host = ThisOutlookSession.Application
      Dim selectedItem As Object
      Dim theMailItem As Outlook.mailitem
      Dim sSendername
      Dim objDestFolder As Outlook.MAPIFolder
      Dim objSourceFolder As Outlook.folder
      Set objSourceFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archive")
      ' Get the user's currently selected item.
      Set selectedItem = host.ActiveExplorer.Selection.Item(1)
      Set theMailItem = selectedItem
      Dim parentFolder As Outlook.folder
      Dim parentStore As Outlook.Store
      Set parentFolder = theMailItem.Parent
      Set parentStore = parentFolder.Store
      If parentStore.IsConversationEnabled Then
      Dim theConversation As Outlook.Conversation
      Set theConversation = theMailItem.GetConversation
      If Not IsNull(theConversation) Then
      Dim itemsTable As Outlook.Table
      Set itemsTable = theConversation.GetTable

      Dim group As Outlook.SimpleItems
      Set group = theConversation.GetRootItems
      Dim obj As Object
      Dim fld As Outlook.folder
      Dim mi As Outlook.mailitem
      sSendername = theConversation.Parent.SentOnBehalfOfName
      If sSendername = ";" Then
      sSendername = theConversation.Parent.SenderName
      End If

      On Error Resume Next
      Set objDestFolder = objSourceFolder.Folders(sSendername)
      If objDestFolder Is Nothing Then
      Set objDestFolder = objSourceFolder.Folders.Add(sSendername)
      End If
      For Each obj In group
      obj.Move objDestFolder
      Next

      End If
      End If

      End Sub

Leave a Reply

Please post long or more complicated questions at OutlookForums by Slipstick.com.

If the Post Comment button disappears, press your Tab key.