0

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.

RajaT
  • 1
  • 3
  • Please post the code you tried out and specify your problems. –  Apr 20 '17 at 14:02
  • @David G, I have updated the question with the code I have tried. It does not move any messages, even though I have emails sent and received going back to 2007 in the folder. I want it to go through all folders, subfolders and their subfolders in inbox and sent items and moved any message older than days specified to "old_mail" folder in inbox. – RajaT Apr 21 '17 at 08:17
  • Have you tried moving a single message from one folder to another? –  Apr 21 '17 at 08:22
  • I have tried but it simply does not work. Just the Msgbox in the end stating "Moved 0 Messages(s)". I am using Office 2013 and Exchange Online which should not make much of a difference. – RajaT Apr 21 '17 at 09:26
  • See my answer below –  Apr 21 '17 at 09:30

1 Answers1

0

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.

Community
  • 1
  • 1
  • @ David G, I have tried this also but there is no difference. – RajaT Apr 21 '17 at 13:21
  • please post the exact code you tried, what happened and what did not happen –  Apr 21 '17 at 13:24
  • The same code as you have posted above, with the change of 'SenderName' to 'User Name' from whom the emails are being received. – RajaT Apr 24 '17 at 08:28
  • Now tell me exactly what happened and what did not happen. Go through the code line by line with your "F8" button. –  Apr 24 '17 at 08:34
  • If i try `Set myItem = myItems.Find("[SenderName] = 'SenderName'")` it works for the sender, moving all items in inbox only not from any subfolders and if i add the date like `While TypeName(myItem) <> "Nothing" And (DateDiff("d", myItem.SentOn, Now)) > 30` it does nothing – RajaT Apr 24 '17 at 13:08
  • So: moving all items from inbox with sender name works now, moving with sender name from subfolder does not work, moving with sening date does not work. Is this correct? –  Apr 24 '17 at 13:25
  • Yes, this is correct. I want to be able to move emails based on date from inbox, subfolders and their subfolders without having to specify the sender, there are more than 1800 senders and same for the sent emails. I had a look at the article on MS site, which does not describe much for such. Any help / pointing in a direction will be highly appreciated. – RajaT Apr 24 '17 at 15:16
  • Did you try the `(DateDiff("d", myItem.SentOn, Now))` in an own sub? Try to combine it with a `debug.print` and check its value and see if you can get a comparable integer –  Apr 24 '17 at 18:56
  • By changing the definition to `Set myItem = myItems.Find("[SentOn] < '" & Format(DateAdd("d", -30, Now), "dd/mm/yyyy") & "'")` I can move items from inbox without specifying sender, but it has to be run for each subfolder. Any way to include ALL subfolders and their subfolders to this? – RajaT Apr 25 '17 at 08:57
  • Please let us go through the problem step by step. So you are saying that now you CAN move all Emails with a specific age from you normal inpox folder, sorrect? And now you need to loop through your subfolders as well, right? –  Apr 25 '17 at 09:00
  • Yes David, this is exactly what I need to do. – RajaT Apr 25 '17 at 09:22
  • I added a link to a function that recursively loops through folders and subfolders. If my answer helped you then please consider accepting/voting it. –  Apr 25 '17 at 10:32
  • David, it was very helpful and I will mark it answered, thank you for your assistance and guidance. I was looking at the same function, prefer to use first one `Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)` I have added the above edited code to ` 'Get your data here ... ` but cannot seem to get it to work for received or sent – RajaT Apr 25 '17 at 10:56
  • What exactly does not work? Are there error messages? Does the code flow as expected? Go through code with "F8", look at values and check for unwanted behaviour –  Apr 25 '17 at 11:01
  • The problem is that I cannot use "F8" or see "processFolder" in the Macro list even though I have removed "Private". I have copied the entire code without Sub A_Old_Email_Sent_Received() & End Sub to the section where it states "**Get your data here ...**" but I cannot run it now. – RajaT Apr 25 '17 at 11:30
  • Here is a good article on how to debug your VBA code step by step: http://www.excel-easy.com/vba/examples/debugging.html –  Apr 25 '17 at 11:40
  • Please be specific with your descriptions. What do you mean with "I cannot use F8"? What happenes when you press that button within your code window? –  Apr 25 '17 at 11:42