Macro to Move Aged Email Messages

We had a question from a user who wanted a macro to move mail to a subfolder as it aged. While you could use AutoArchive to do this quickly and easily, no coding required, AutoArchive moves mail to a *.pst file, not a subfolder. If you don't care where the mail is moved to, just that its out of your Inbox, use AutoArchive, set to run every 1 day and configure the Inbox archive setting to the desired number of days.

To use, assign the macro to a command button and run as needed. You could also use this as an application start macro and have it run when Outlook starts.

If you aren't a big fan of moving mail, you can leave it in the Inbox and use custom views to hide older mail.

There are 4 macros on this page plus one code snippet. Two macros show you how to move messages to a folder within your current data file and to move messages to a folder in a new data file. The third macro on this page shows you how to use a Select Case statement to move different Outlook items types, using a different age for each item type. The code sample gives you the code needed to move only messages you've replied to or forwarded. "Macro to file Outlook email by sender's display name" has versions that file into folders by name, domain, or date.

VBA Macro to Move Aged Email Messages

This code sample checks the default Inbox for email older that 7 days and moves any it finds to a subfolder of the Inbox, called Old.

You'll need to set the age, in days, to your desired number. This sample uses 7 days. You'll also need to replace the data file name.

In this sample, the data file name is an email address because that is what Outlook 2010 uses for data file names. You'll need to change this as well as the folder path you are moving the email to.

Tested in Outlook 2010 and Outlook 2013 with an Exchange mailbox.

The Date field can either be SentOnor ReceivedTime when you are working with email or meeting request and responses.

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)
    
    ' use a subfolder under Inbox
    Set objDestFolder = objSourceFolder.Folders("Old")

    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 7 days, adjust as needed. 
            If intDateDiff > 7 Then

              objVariant.Move objDestFolder
              
              'count the # of items moved
               lngMovedItems = lngMovedItems + 1

            End If
        End If
    Next
    
    ' Display the number of items that were moved.
    MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub

Move messages to a different data file

If you want to move the messages to a new data file, you need to change the destination folder path: Set objDestFolder = objNamespace.Folders("me@domain.com").Folders("Inbox").Folders("Old") to use the GetFolderPath function: Set objDestFolder = GetFolderPath("new-pst-file\folder-name").

That line is the only change needed to use a different data file (well, that line and the function).

Tip: A function can be used by any macro, so I keep the functions together in a separate module. When I add a macro that uses a function, I can easily see if I have that function already.

Sub MoveAgedMail2()
 
'Get the function fromhttp://slipstick.me/qf
    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

    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
     
 'Use a folder in a different data file   
           Set objDestFolder = GetFolderPath("my-data-file-name\Inbox")

    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)
              
           ' adjust number of days as needed.
            If intDateDiff > 60 Then

              objVariant.Move objDestFolder
               
              'count the # of items moved
               lngMovedItems = lngMovedItems + 1

            End If
        End If
    Next
     
    ' Display the number of items that were moved.
    MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub

Move mail you've replied to or forwarded

With a few simple changes, you can convert the macro above to move messages that were replied to or forwarded.

Begin by adding these lines to the top of the macro with the other Dim statements.

Dim lastverb, lastaction As String
Dim propertyAccessor As Outlook.propertyAccessor

Using the first macro on this page as the base, replace the code block between the If objVariant.Class... and objVariant.Move lines with the code block below. Because Reply, Reply all, and Forward values are 102, 103, and 104, and to the best of my knowledge, those are the only possible values, we can leave the lastaction value at 7 (was intDateDiff in the original macro).

        If objVariant.Class = olMail Then
       
     Set propertyAccessor = objVariant.propertyAccessor

       lastverb = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
       lastaction = propertyAccessor.GetProperty(lastverb)
             
    ' 102, 103, 104 are replied, forwarded, reply all
           If lastaction > 7 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
           Set objDestFolder = objNamespace.Folders("diane@domain.com"). _
                   Folders("Inbox").Folders("completed")
 
              objVariant.Move objDestFolder

Use Case Statements instead of IF statements

This code sample uses Case statement to get the ReceivedTime or CreationTime of email, meeting requests and responses, as well as read receipt reports, then plugs the date value into the calculation. It also allows you to use different dates for each group of items types.

Sub MoveAgedItems()
 
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objSourceFolder As Outlook.MAPIFolder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim obj As Variant
    Dim sDate As Date
    Dim sAge As Integer
    Dim lngMovedItems As Long
    Dim intDateDiff As Integer
    Dim intCount As Integer

    
    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
    Set objDestFolder = objSourceFolder.Folders("Old")
 
    For intCount = objSourceFolder.Items.Count To 1 Step -1
    Set obj = objSourceFolder.Items.Item(intCount)
        DoEvents
 
     Select Case obj.Class
        Case olMail
            sDate = obj.ReceivedTime
            sAge = 180
                    
        Case olMeetingResponseNegative, _
            olMeetingResponsePositive, _
            olMeetingCancellation, olMeetingRequest, _
            olMeetingAccepted, olMeetingTentative
            sDate = obj.ReceivedTime
            sAge = 10
                    
        Case olReport
            sDate = obj.CreationTime
            sAge = 10
        Case Else
            GoTo NextItem
      End Select
        
intDateDiff = DateDiff("d", sDate, Now)
   If intDateDiff > sAge Then
      obj.Move objDestFolder
      
        lngMovedItems = lngMovedItems + 1
  End If
  
NextItem:
Next

    ' Display the number of items that were moved.
    MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing

End Sub

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