Why is the following VBA script not moving items based on date and category? It is moving items older than seven days to a different folder called old, however it appears the items it is moving are random, not items in the AFG category.
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
' use a subfolder under Inbox
Set objDestFolder = objSourceFolder.Folders("Old")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 7 days, adjust as needed.
If intDateDiff > 7 And objVariant.Categories = AFG Then
objVariant.Move objDestFolder
' MsgBox intDateDiff
'count the # of items moved
lngMovedItems = lngMovedItems + 1
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub
Edit - Sorry my code is a rough work in progress.
If it is too hard to understand I can try and clean it up!
I didn't put quotes around AFG.
If intDateDiff > 7 And objVariant.Categories = AFG Then
becomes
If intDateDiff > 7 And objVariant.Categories = "AFG" Then
My bad.
Related
I have the following code in Outlook. On my first attempt the deleted mail was sent to my main account inbox and not the shared mailbox.
I would like to
1- pick the shared delete folder by default
2- avoid looping the delete folder
3- speed up the code if possible as size of mail box is > 1 Million mails.
It is error free but I can track the progress.
Dim objNameSpace As Outlook.NameSpace
Dim objMainFolder As Outlook.Folder
Dim olNs As NameSpace
Dim lngItem As Long
Dim Mails_itm As MailItem
Dim myNameSpace As Outlook.NameSpace
Dim myInboxDest As Outlook.Folder
Dim myInboxSc As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set objNameSpace = Application.GetNamespace("MAPI")
Set objMainFolder = objNameSpace.PickFolder
Call ProcessCurrentFolder(objMainFolder)
End Sub
ProcessCurrentFolder(ByVal objParentFolder As Outlook.MAPIFolder)
Dim objCurFolder As Outlook.MAPIFolder
Dim objMail As Outlook.MailItem
Dim DeletedFolder As Outlook.Folder
Dim olNs As Outlook.NameSpace
Dim lngItem As Long
On Error Resume Next
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
For Each objMail In objParentFolder.Items
i = 0
For lngItem = objParentFolder.Items.Count To 1 Step -1
Set objMail = objParentFolder.Items(lngItem)
If TypeName(objMail) = "MailItem" Then
If ((objMail.ReceivedTime) < DateAdd("yyyy", -7, Date)) Then
objMail.Move DeletedFolder
i = i + 1
End If
End If
DoEvents
Next lngItem
Next
If (objParentFolder.Folders.Count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder)
Next
End If
End Sub
When placing a question, it is good to check it from time to time and answer the clarification questions, if any...
Supposing that your first required issue means replacing the folder picker option and directly setting objMainFolder, your first code should be adapted as:
Sub ProcessOldMails()
Dim objNameSpace As outlook.NameSpace
Dim objMainFolder As outlook.Folder
Set Out = GetObject(, "Outlook.Application")
Set objNameSpace = Out.GetNamespace("MAPI")
Set objNameSpace = Application.GetNamespace("MAPI")
'Set objMainFolder = objNameSpace.PickFolder 'uncomment if my supposition is wrong
'set the folder to be processed directly, if it is an InBox subfolder:
'Please use its real name instead of "MyFolderToProcess":
Set objMainFolder = objNameSpace.GetDefaultFolder(olFolderInbox).Folders("MyFolderToProcess")
ProcessCurrentFolder objMainFolder, Application
End Sub
In order to make the process faster, you can filter the folder content and iterate only between the remained mails:
Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
Dim objCurFolder As outlook.MAPIFolder
Dim objMail As outlook.MailItem
Dim DeletedFolder As outlook.Folder
Dim olNs As outlook.NameSpace
Dim lngItem As Long, strFilter As String, oItems As items
Set olNs = app.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
strFilter = "[ReceivedTime]<'" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
For lngItem = oItems.count To 1 Step -1
oItems(lngItem).Move DeletedFolder
Next lngItem
If (objParentFolder.Folders.count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder, app)
Next
End If
End Sub
I used app second parameter only because I tried it as an Outlook automation from Excel, and it was easier to insert only two lines...
Please, test the suggested solution and send some feedback. If my understanding was not a correct one, do not hesitate to ask for clarifications, firstly answering my questions from the comment.
Now, I need to go out...
Use the Find/FindNext or Restrict methods to get items that correspond to your conditions instead of iterating over all items in the folder. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
When you iterate over found items and move them to another folder you must use a reverse loop which allows prevent errors at runtime because decreasing the number of items by calling the Move method leads to decreasing the number of items.
Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
Dim objCurFolder As outlook.MAPIFolder
Dim objMail As outlook.MailItem
Dim DeletedFolder As outlook.Folder
Dim olNs As outlook.NameSpace
Dim lngItem As Long, strFilter As String, oItems As items
Set olNs = app.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
strFilter = "[ReceivedTime] < '" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
For i = oItems.Count to 1 Step -1
Set objMail = oItems(i)
objMail.Move DeletedFolder
Next
' it makes sense to move this part to the beginning of the method to process subfolders first
If (objParentFolder.Folders.count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder, app)
Next
End If
End Sub
See For Each loop: Some items get skipped when looping through Outlook mailbox to delete items for more information.
I am looking for a macro to move earlier email in a conversation (sorted by subject) to a subfolder, except the latest conversation in that subject.
Upon receiving a new mail on the same conversation, then move the older email to subfolder.
I found the base to move emails older than 7 days, but not sure how to move older conversations and leave only the latest mail.
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
'Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objSourceFolder = objNamespace.Folders("Online Archive - OTCGROUP#abc.ssmb.com").Folders("Inbox").Folders("DEST1")
' use a subfolder under Inbox
'Set objDestFolder = objSourceFolder.Folders("DEST")
Set objDestFolder = objNamespace.Folders("Online Archive - OTCGROUP2#abc.ssmb.com").Folders("Inbox").Folders("DEST2")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
' I'm using 7 days, adjust as needed.
If intDateDiff > 7 Then
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
End If
End If
Next
' Display the number of items that were moved.
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub
Iterating through all items in the folder is not really a good idea:
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
Use the Find/FindNext or Restrict methods of the Items class instead. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
I'm trying to delete sent items that contain "invoice" in the subject that are more than 30 days old.
It works for emails older than 30 days but doesn't applying the filter on the subject.
The code I'm currently using
Sub MoveAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim Items As Outlook.Items
Dim Filter As String
Dim intDateDiff As Integer
Dim strDestFolder As String
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
Filter = "[Subject] = '%" & "invoice" & "%' And [SenderEmailAddress] = _
'abc #hotmail.com'"
Set Items = objSourceFolder.Items.Restrict(Filter)
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
If intDateDiff > 30 Then
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
End If
End If
Next
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub
You must work with a restricted set of items instead of getting a new items collection, for example:
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
It should be rewritten as the following:
For intCount = Items.Count To 1 Step -1
Set objVariant = Items.Item(intCount)
You may find the following articles helpful:
How To: Use Restrict method to retrieve Outlook mail items from a folder
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
Do not use Items as a variable.
Sub MoveAgedMail()
'Dim objOutlook As Outlook.Application
'Dim objNamespace As Outlook.NameSpace
Dim objNamespace As NameSpace
'Dim objSourceFolder As Outlook.MAPIFolder
Dim objSourceFolder As Folder
'Dim objDestFolder As Outlook.MAPIFolder
Dim objDestFolder As Folder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
'Dim Items As Outlook.Items ' Do not use Items as a variable
Dim resItems As Items
Dim Filter As String
Dim intDateDiff As Integer
Dim strDestFolder As String
'Set objOutlook = Application ' not necessary
'Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objNamespace = GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Debug.Print "objSourceFolder.Items.Count: " & objSourceFolder.Items.Count
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
' ?
Filter = "[Subject] = '%" & "invoice" & "%' And [SenderEmailAddress] =" 'abc #hotmail.com'"
Debug.Print Filter
Filter = "[Subject] = '%" & "invoice" & "%'"
Debug.Print Filter
Set resItems = objSourceFolder.Items.Restrict(Filter)
Debug.Print "objSourceFolder.Items.Count: " & objSourceFolder.Items.Count
Debug.Print "resItems.Count: " & resItems.Count
'For intCount = objSourceFolder.Items.Count To 1 Step -1
For intCount = resItems.Count To 1 Step -1
Set objVariant = resItems.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
If intDateDiff > 30 Then
objVariant.Move objDestFolder
'count the # of items moved
lngMovedItems = lngMovedItems + 1
End If
End If
Next
MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub
i have a code that copies the emails that are older than 2 days in an archive but if i want to copy the emails in an archive subfolder, it will not do the job. any help is welcomed.
Sub Copy_d_2()
Dim myOutlookFolders As Outlook.Folder
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Folder
Dim objSourceFolder As Outlook.Folder
Dim objSourceFolderMAIN As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim a As Date
a = Now()
Dim b As String
b = Format(a, "mmmm")
Dim c As String
c = Format(a, "yyyy")
Dim nam As String
nam = "Archive me " & b & " " & c
Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
Set objSourceFolder = Session.Folders("Mailbox - Share").Folders("Inbox").Folders("all emails")
Set objSourceFolderMAIN = Session.Folders("Archive Folders")
Set objDestFolder = Session.Folders("Archive Folders").Folders(nam).Folders("d2")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
intDateDiff = DateDiff("d", objVariant.SentOn, Now)
If intDateDiff > 2 Then
objVariant.Copy objDestFolder
lngMovedItems = lngMovedItems + 1
End If
End If
Next
Set objDestFolder = Nothing
End Sub
Here is something similar:
How to move each emails from inbox to a sub-folder
However, concerning your code, I have played a little and managed to do this:
Sub Copy_d_2()
Dim myOutlookFolders As Outlook.Folder
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Folder
Dim objSourceFolder As Outlook.Folder
Dim objSourceFolderMAIN As Outlook.Folder
Dim objDestFolder As Outlook.Folder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim a As Date
a = Now()
Dim b As String
b = Format(a, "mmmm")
Dim c As String
c = Format(a, "yyyy")
Dim nam As String
nam = "Archive me " & b & " " & c
Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
Set objSourceFolder = Session.Folders("review#vitoshacademy.com").Folders("Posteingang").Folders("InboxX")
'Set objSourceFolderMAIN = Session.Folders("Archive")
Set objDestFolder = Session.Folders("Archive").Folders("test1").Folders("test2")
For intCount = objSourceFolder.Items.Count To 1 Step -1
Set objVariant = objSourceFolder.Items.Item(intCount)
DoEvents
If objVariant.Class = olMail Then
objVariant.Move objDestFolder
End If
Next
Set objDestFolder = Nothing
End Sub
It moves the mail to the subfolder without problems. And without checking whether it is at least 2 days old.
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
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
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
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")