Outlook 2007 Archive Macro
My co-workers and I have noticed a bug in the Microsoft Outlook Auto-Archive Feature. The bug is that it simply does not do anything. To fix this problem for me I wrote a macro that moves all of the old mail from my Inbox sub-folders to the directory that I choose when I run the macro.
The script moves all the messages older than "8" days from the 5 SubFolders by their respective names. This perticular script only works one sub level into the inbox. You will need to change the names of the folders in the array from SubFolderX to whatever the names of your inbox subfolders are. You can also easily remove or add the number of folders the array consists of and change the "Const Days =" to something other than 8 if you so choose.
The script moves all the messages older than "8" days from the 5 SubFolders by their respective names. This perticular script only works one sub level into the inbox. You will need to change the names of the folders in the array from SubFolderX to whatever the names of your inbox subfolders are. You can also easily remove or add the number of folders the array consists of and change the "Const Days =" to something other than 8 if you so choose.
Sub MoveOldItems()
Dim olns As Outlook.NameSpace
Dim oConItems As Outlook.Items
Dim iNumItems As Integer
Dim dDate As Date
Dim myArray(4)
Const Days = 8
Today = Format(Now(), "mm-dd-yy")
myArray(0) = "SubFolder1"
myArray(1) = "SubFolder2"
myArray(2) = "SubFolder3"
myArray(3) = "SubFolder4"
myArray(4) = "SubFolder5"
Set objNS = Application.GetNamespace("MAPI")
Set objTargetFolder = Outlook.Session.PickFolder
For Each present In myArray
Set oInboxItems = objNS.GetDefaultFolder(olFolderInbox).Folders(present).Items
iNumItems = oInboxItems.Count
For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
' Move only mail messages
dDate = objCurItem.ReceivedTime
If DateDiff("d", dDate, Now) > Days Then
objCurItem.Move objTargetFolder
End If
End If
Next
Next
MsgBox "All Done."
MsgBox objTargetFolder
Set objInboxItems = Nothing
Set objTargetFolder = Nothing
Set objNS = Nothing
End Sub
Dim olns As Outlook.NameSpace
Dim oConItems As Outlook.Items
Dim iNumItems As Integer
Dim dDate As Date
Dim myArray(4)
Const Days = 8
Today = Format(Now(), "mm-dd-yy")
myArray(0) = "SubFolder1"
myArray(1) = "SubFolder2"
myArray(2) = "SubFolder3"
myArray(3) = "SubFolder4"
myArray(4) = "SubFolder5"
Set objNS = Application.GetNamespace("MAPI")
Set objTargetFolder = Outlook.Session.PickFolder
For Each present In myArray
Set oInboxItems = objNS.GetDefaultFolder(olFolderInbox).Folders(present).Items
iNumItems = oInboxItems.Count
For I = iNumItems To 1 Step -1
Set objCurItem = oInboxItems.Item(I)
If TypeName(objCurItem) = "MailItem" Then
' Move only mail messages
dDate = objCurItem.ReceivedTime
If DateDiff("d", dDate, Now) > Days Then
objCurItem.Move objTargetFolder
End If
End If
Next
Next
MsgBox "All Done."
MsgBox objTargetFolder
Set objInboxItems = Nothing
Set objTargetFolder = Nothing
Set objNS = Nothing
End Sub