Move emails from a mailbox to a specific folder within same mailbox which are older than x days or x years

Question

I am looking to move all email messages (sent and received) from a mailbox ( to include inbox, subfolders and their subfolders, sent items, subfolders and their subfolders ) to a specific folder within same mailbox (the folder is in the inbox called old_mail) which are older than x days or x years.

I have tried creating rules and few suggestions on stackoverflow but none seems to be working.

I would prefer a VBA script but any help and solution will be accepted.

Thank you in advance.

Please see below the code:

Sub A_Email_Filter()
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)

'A subfolder under Inbox
Set objDestFolder = objSourceFolder.Folders("Old_Email")

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, "01/01/2016")

        'Days old, adjust as needed.
        If intDateDiff > 2300 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

This seems to be for sent items only but it does not work and i need to move everything, sent and received which is older than the days defined.

I have the below working for inbox and sent mail at the same time now

Sub A_Old_Email_Sent_Received()

   Dim myNameSpace As Outlook.NameSpace
   Set myNameSpace = Application.GetNamespace("MAPI")

   Dim myInbox As Outlook.Folder
   Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)

   Dim mySentbox As Outlook.Folder
   Set mySentbox = myNameSpace.GetDefaultFolder(olFolderSentMail)

   Dim myDestFolder As Outlook.Folder
   Set myDestFolder = myInbox.Folders("Old_Email")

   Dim myReceivedItems As Outlook.Items
   Set myReceivedItems = myInbox.Items

   Dim mySentItems As Outlook.Items
   Set mySentItems = mySentbox.Items

   Dim myItemCountInbox As Integer
   Dim myItemCountSentbox As Integer

   Dim myReceivedItem As Object
   Dim mySentItem As Object

   '### Received Email
   'Based on their Age -## days Old, Date
   Set myReceivedItem = myReceivedItems.Find("[SentOn] < '" & Format(DateAdd("d", -10, "24/04/2017"), "dd/mm/yyyy") & "'")
   'Get to work - Inbox
   While TypeName(myReceivedItem) <> "Nothing"
      myReceivedItem.Move myDestFolder
      Set myReceivedItem = myReceivedItems.FindNext
      myItemCountInbox = myItemCountInbox + 1
   Wend
   MsgBox "Number of received emails moved: " & myItemCountInbox, vbInformation, "Received Emails"

   '### Sent Email
   'Based on their Age -## days Old, Date
   Set mySentItem = mySentItems.Find("[SentOn] < '" & Format(DateAdd("d", -10, "24/04/2017"), "dd/mm/yyyy") & "'")
   'Get to work - Sent Items
   While TypeName(mySentItem) <> "Nothing"
      mySentItem.Move myDestFolder
      Set mySentItem = mySentItems.FindNext
      myItemCountSentbox = myItemCountSentbox + 1
   Wend
   MsgBox "Number of sent emails moved: " & myItemCountSentbox, vbInformation, "Sent Emails"
End Sub

Not sure how to add the function to loop through.

Answer 1

Taken from MS documentation , this should give you a solid start

Move mails with the sender name "SenderName" into the folder "Old_Email":

Sub MoveItems() 
 Dim myNameSpace As Outlook.NameSpace 
 Dim myInbox As Outlook.Folder 
 Dim myDestFolder As Outlook.Folder 
 Dim myItems As Outlook.Items 
 Dim myItem As Object 

 Set myNameSpace = Application.GetNamespace("MAPI") 
 Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox) 
 Set myItems = myInbox.Items
 'specify the destination folder
 Set myDestFolder = myInbox.Folders("Old_Email")
 'specify the condition, change to date
 Set myItem = myItems.Find("[SenderName] = 'SenderName'") 
 While TypeName(myItem) <> "Nothing" 
 myItem.Move myDestFolder 
 Set myItem = myItems.FindNext 
 Wend 
End Sub

To move mails older than 7 days try this:

If (DateDiff("d", myItem.SentOn, Now)) > 7
   'move mail
End If

Edit: Here you can find a function that goes through folders and its subfolders recursively. Adapt for your needs.