Emails to a distribution group aren't MailItems? - vba

Question

I'm trying to write a VBA script for Outlook 2007 that moves a user's mail to an "Expired" folder if it's older than 89 days. I have code to do this, but it doesn't seem to work for aged emails that were to a distribution group that includes the end user. It works for emails just sent to the end user.
I combined code I found online for a) moving emails when they are a certain number of days old (http://www.slipstick.com/developer/macro-move-aged-mail/), and b) recursing through a folder to apply the code to subfolders as well (Can I iterate through all Outlook emails in a folder including sub-folders?). This code recurses through the Inbox folder and subfolders to move all aged mail.
It more or less works, but for some reason emails to a distribution list that includes the end user are not being picked up. The only remarkable check I have is that
If TypeName(oItem) = "MailItem"
Are distribution list emails not considered MailItems? If not, how do I make sure to catch those too?
Here is the complete code:
Public Sub MoveAgedMail(Item As Outlook.MailItem)
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Folder As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
' Call processFolder
processFolder objSourceFolder
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oItem As Object
Dim intCount As Integer
Dim intDateDiff As Long
Dim objDestFolder As Outlook.MAPIFolder
' "Expired" folder at same level as Inbox for sending aged mail
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")
For Each oItem In oParent.Items
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
' Check if email is older than 89 days
intDateDiff = DateDiff("d", oMail.SentOn, Now)
If intDateDiff > 89 Then
' Move to "Expired" folder
oMail.Move objDestFolder
End If
End If
Next oItem
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
Set objDestFolder = Nothing
End Sub

Answer 1

Firstly, do not use for each if you are modifying a collection - that will cause your code to skip half the items.
Secondly, do not just loop through all items in a folder, this is extremely inefficient. Use Items.Restrict or Items.Find/FindNext.
Try something like the following (VB script):
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
set oItems = oParent.Items.Restrict(strFilter)
for i = oItems.Count to 1 step -1
set oItem = oItems.Item(i)
Debug.Print oItem.Subject & " " & oItem.SentOn
next

Answer 2

Try not to process Expired Folder
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
Debug.Print oFolder
' No need to process Expired folder
If oFolder.Name <> "Expired" Then
processFolder oFolder
End If
Next
End If
also try using down loop when moving mail items, see Dmitry Streblechenko example
Edit
Items.Restrict Method (Outlook)
Complete Code- Tested on Outlook 2010
Sub MoveAgedMail(Item As Outlook.MailItem)
Dim olNameSpace As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olNameSpace = Application.GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
' // Call ProcessFolder
ProcessFolder olInbox
End Sub
Function ProcessFolder(ByVal Parent As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim iCount As Integer
Dim iDateDiff As Long
Dim vMail As Variant
Dim olItems As Object
Dim sFilter As String
iDateDiff = Now - 89
sFilter = "[SentOn] < '" & Month(iDateDiff) & "/" & Day(iDateDiff) & "/" & Year(iDateDiff) & "'"
' // Loop through the items in the folder backwards
Set olItems = Parent.Items.Restrict(sFilter)
For iCount = olItems.Count To 1 Step -1
Set vMail = olItems.Item(iCount)
Debug.Print vMail.Subject ' helps me to see where code is currently at
' // Filter objects for emails
If vMail.Class = olMail Then
Debug.Print vMail.SentOn
' // Retrieve a folder for the destination folder
Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Expired")
' // Move the emails to the destination folder
vMail.Move DestFolder
' // Count number items moved
iCount = iCount + 1
End If
Next
' // Recurse through subfolders
If (Parent.Folders.Count > 0) Then
For Each Folder In Parent.Folders
If Folder.Name <> "Expired" Then ' skip Expired folder
Debug.Print Folder.Name
ProcessFolder Folder
End If
Next
End If
Debug.Print "Moved " & iCount & " Items"
End Function

Answer 3

This is my code now. Originally, I moved my old mail to an "Expired" folder and had autoarchive delete the messages, but I was having issues with autoarchive on some machines. I rewrote the script to delete old email. It uses Dmitry Streblechenko's suggestions, and it seems to work.
Public Sub DeleteAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objSourceFolderSent As Outlook.MAPIFolder
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objSourceFolderSent = objNamespace.GetDefaultFolder(olFolderSentMail)
processFolder objSourceFolder
processFolder objSourceFolderSent
emptyDeleted
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oItems As Outlook.Items
Dim oItem As Object
Dim intDateDiff As Long
Dim d As Long
Dim strFilter As String
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
Set oItems = oParent.Items.Restrict(strFilter)
For i = oItems.Count To 1 Step -1
Set oItem = oItems.Item(i)
If TypeName(oItem) = "MailItem" Then
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
End If
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
Public Sub emptyDeleted()
Dim objOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim objDeletedFolder As Outlook.MAPIFolder
Dim objProperty As Outlook.UserProperty
Set objOutlook = Application
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set objDeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
If you want to just move emails and not delete them, like in my original code, you could get rid of the emptyDeleted() function, change
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
back to
oItem.Move objDestFolder
and add these two lines back to the processFolder() function:
Dim objDestFolder As Outlook.MAPIFolder
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")