The Cleanup Macro
I recently had a problem with autoarchive which probably exists in all large corporations with lower end users. We have an email cleanup initiative underway and a user took emails that were quite a few years old and moved them into individual folders. Doing that changed the Modify date on them.
Then when I set up an autoarchive it would not work on these emails even though some are five years old. I also could find only one program which would change the Modify date and it is not for an Exchange mailbox. My solution was to create a macro to drill down through two levels of directories in the inbox and move messages with a Receive date older than two months. It worked quite well.
Sub ArchByDate() Dim myOlApp As New Outlook.Application Dim myNameSpace As Outlook.NameSpace Dim myInbox As Outlook.MAPIFolder Dim myInbox2 As Outlook.MAPIFolder Dim myDestFolder As Outlook.MAPIFolder Dim myItems As Outlook.Items Dim myItem As Object Dim cmpdate As Date Dim mydest, mydest2 As String Set myNameSpace = myOlApp.GetNamespace("MAPI") Set myInbox2 = myNameSpace.GetDefaultFolder(olFolderInbox) cmpdate = DateAdd("m", -2, Date) For x = 1 To myInbox2.Folders.Count Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(x) Set myItems = myInbox.Items Set myItem = myItems.Find("[SENDERNAME] <> ''") While TypeName(myItem) <> "Nothing" If cmpdate > myItem.ReceivedTime Then mydest = myInbox Set myDestFolder = myNameSpace.Folders("Archive Folders").Folders("Inbox").Folders(mydest) myItem.Move myDestFolder End If Set myItem = myItems.FindNext Wend mydest = myInbox If myInbox.Folders.Count > 0 Then For y = 1 To myInbox.Folders.Count Set myInbox3 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(x).Folders(y) Set myItems = myInbox3.Items Set myItem = myItems.Find("[SENDERNAME] <> ''") While TypeName(myItem) <> "Nothing" If cmpdate > myItem.ReceivedTime Then mydest2 = myInbox3 Set myDestFolder = myNameSpace.Folders("Archive Folders").Folders("Inbox").Folders(mydest).Folders(mydest2) myItem.Move myDestFolder End If Set myItem = myItems.FindNext Wend Next End If Next End Sub
This looks at every email in all directories below the Inbox and then moves it to the same directory in Archive Folders based on Receive date. It does not check for the existence of that folder or create it. It also does not touch the Inbox items or items deeper than a second-level directory (Inbox –> Mail –> Mail 2 –> Mail 3, this would not touch the Mail 3 folder). I did not need to verify the folders since Autoarchive had already created the folder structure.