Here is an Outlook macro I whipped up a little while ago since my inbox was so insane I was having trouble even selecting all of the email in it. As you can see my version is heavily modified from a source article I found here ( http://blogs.iis.net/robert_mcmurray/archive/2010/02/25/outlook-macros-part-1-moving-emails-into-personal-folders.aspx )
There are a few things to note… use at your own risk is the first. Second, this only does a folder deep in the inbox mostly because I didn’t feel like writing a recursion method. There is limited error checking, I wanted it to crash vs try to survive and screw up my email. For this to work you must have a datafile added for each year in YYYY (2010, 2009, etc) format. The macro will attempt to create any subfolders that it needs. Macro is as follows, if you make any huge improvements to it please let me know.
Sub MoveOldEmails()
'NOTE: This does Sent Items, Inbox, and 1 folder below inbox. It will not do more than 1 folder deep in the inbox.
' Declare all variables.
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objInbox As Outlook.Folder
Dim objSentbox As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objMail As Variant
Dim intCount As Integer
Dim intDateDiff As Integer
Dim intAge As Integer
'Move anything older than this date.
intAge = 30
' Create an object for the Outlook application.
Set objOutlook = Application
' Retrieve an object for the MAPI namespace.
Set objNamespace = objOutlook.GetNamespace("MAPI")
' Retrieve a folder object for the inbox folder
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'Retrieve a folder object for sent box folder
Set objSentbox = objNamespace.GetDefaultFolder(olFolderSentMail)
' Note: Using cached mode with exchange is much faster, non-cached mode will take 1-2 seconds per email
' since a request is made for every object vs using a local cache.
'Move sent items first.
For intCount = objSentbox.Items.Count To 1 Step -1
' Loop through the items in the folder. NOTE: This has to
' be done backwards; if you process forwards you have to
' re-run the macro an inverese exponential number of times.
Set objMail = objSentbox.Items.Item(intCount)
intDateDiff = DateDiff("d", objMail.SentOn, Now)
Debug.Print intDateDiff & ":" & objMail.SentOn
'Move anything older than intAge
If intDateDiff > intAge Then
'Set blnFound to False, it will be set to true by logic if the folder does not need to be created
blnFound = False
For Each objFolder In objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders
'This is sloppy since we will loop through all of the folders to see if the folder exists
'for every mail item, I could make an array and do a search on it but this should be run in
'cached mode so there is not much of a difference. This is however, very much not optimal
If objFolder.Name = objSentbox.Name Then
'If the current folder matches our search folder set blnFound to true to skip folder creation
blnFound = True
End If
Next
If blnFound = False Then
'Create the folder if it was not found
objNamespace.Folders(CStr(Year(objMail.SentOn))).Add objSentbox.Name
End If
Debug.Print objMail.SentOn & ":" & objMail.Subject
'Set the destination to the same structure as the source folder, i.e. "2010Sent Items"
Set objDestFolder = objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders(objSentbox.Name)
'Move the object - technically mail is not the best name since this can be calendar items etc but I liked it more than "variant"
objMail.Move objDestFolder
'Destroy object for clarity
Set objDestFolder = Nothing
End If
Next intCount
'Next move everything in the root of the default Inbox
For intCount = objInbox.Items.Count To 1 Step -1
Set objMail = objInbox.Items.Item(intCount)
intDateDiff = DateDiff("d", objMail.SentOn, Now)
If intDateDiff > intAge Then
blnFound = False
For Each objFolder In objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders
If objFolder.Name = objInbox.Name Then
blnFound = True
End If
Next
If blnFound = False Then
objNamespace.Folders(CStr(Year(objMail.SentOn))).Add objInbox.Name
End If
Debug.Print objMail.SentOn & ":" & objMail.Subject
' folder structure i.e. "2010Inbox"
Set objDestFolder = objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders(objInbox.Name)
objMail.Move objDestFolder
Set objDestFolder = Nothing
End If
Next intCount
'Loop through all the folders in the inbox
For intFolderCount = 1 To objInbox.Folders.Count
For intCount = objInbox.Folders(intFolderCount).Items.Count To 1 Step -1
DoEvents
Set objMail = objInbox.Folders(intFolderCount).Items.Item(intCount)
intDateDiff = DateDiff("d", objMail.SentOn, Now)
If intDateDiff > intAge Then
blnFound = False
For Each objFolder In objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders(objInbox.Name).Folders
If objFolder.Name = objInbox.Folders(intFolderCount).Name Then
blnFound = True
End If
Next
If blnFound = False Then
objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders(objInbox.Name).Folders.Add objInbox.Folders(intFolderCount).Name
End If
Debug.Print objInbox.Folders(intFolderCount).Name & ":" & objMail.SentOn & ":" & objMail.Subject
' folder structure i.e. "2010InboxsubFolder"
Set objDestFolder = objNamespace.Folders(CStr(Year(objMail.SentOn))).Folders(objInbox.Name).Folders(objInbox.Folders(intFolderCount).Name)
objMail.Move objDestFolder
Set objDestFolder = Nothing
End If
Next intCount
Next intFolderCount
Debug.Print "Done"
End Sub
Enjoy
Comments are closed.