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.
