Deleting email in subfolders

[nt1]

Hi guys,

I'm using a custom VBA script that deletes emails older than 90 days unless categorized as "Archive".

I noticed it only deletes in the default folders like inbox, sent etc. but never gets to delete in the subfolders.

I am using Outlook 2013.

Why does this script not also look in subfolders?

Private Sub Application_Startup()
'when outlook opens
RemoveEmail90

End Sub



Public Sub RemoveEmail90()

'Permanently delete items older than 90 days that do NOT have the category 'Archive' attached.
'Applies to Inbox, Draft, Sent and Junk
'Runs on startup


Dim olInbox As Outlook.Folder
Dim olDraft As Outlook.Folder
Dim olSent As Outlook.Folder
Dim olJunk As Outlook.Folder
Dim olDeleted As Outlook.Folder


Dim i As Integer


Set olInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set olDraft = Application.Session.GetDefaultFolder(olFolderDrafts)
Set olSent = Application.Session.GetDefaultFolder(olFolderSentMail)
Set olJunk = Application.Session.GetDefaultFolder(olFolderJunk)
Set olDeleted = Application.Session.GetDefaultFolder(olFolderDeletedItems)

'''''''''' INBOX

Set Outlook_Items = olInbox.Items

For i = (Outlook_Items.Count) To 1 Step -1

If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then

If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then

Outlook_Items.Item(i).Delete

End If

End If

Next

''''''''''' DRAFT

Set Outlook_Items = olDraft.Items

For i = (Outlook_Items.Count) To 1 Step -1

If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then

If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then

Outlook_Items.Item(i).Delete

End If

End If

Next

''''''''''' SENT
Set Outlook_Items = olSent.Items

For i = (Outlook_Items.Count) To 1 Step -1


If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then

If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then

Outlook_Items.Item(i).Delete

End If



End If


Next

''''''''''' JUNK
Set Outlook_Items = olJunk.Items

For i = (Outlook_Items.Count) To 1 Step -1


If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then

If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then

Outlook_Items.Item(i).Delete

End If

End If


Next

''''''''''' DELETED
Set Outlook_Items = olDeleted.Items

For i = (Outlook_Items.Count) To 1 Step -1


If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then

If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then

'======= this is the line (below) to uncomment after first run ===============

Outlook_Items.Item(i).Delete

'==============================================================

'If it's the first run, leave the above line commented - it will leave emails in the deleted items
'this is a safety measure
'Check if the script ran correctly, Empty deleted items manually,
'uncheck comment, save.

End If


End If


Next

Set olInbox = Nothing
Set olDraft = Nothing
Set olSent = Nothing
Set olJunk = Nothing
Set olDeleted = Nothing


End Sub

[gmayor]

It doesn't delete from sub folders because your code only addresses the root folders. You need to loop through the available folders - see the example in my reply at http://www.vbaexpress.com/forum/showthread.php?54527-Help-with-recursing-through-Mail-sub-folders-and-exporting-to-Excel

In this case the following should work. If you don't want to process the deleted folder while testing, change the line
For i = 0 To 4
to
For i = 0 To 3


Public Sub RemoveEmail90()

'Permanently delete items older than 90 days that do NOT have the category 'Archive' attached.
'Applies to Inbox, Draft, Sent and Junk
'Runs on startup

Dim olRoot(4) As Outlook.Folder
Dim olFolder As Outlook.Folder
Dim subFolder As Outlook.Folder
Dim cFolders As New Collection
Dim i As Long
Set olRoot(0) = Application.Session.GetDefaultFolder(olFolderInbox)
Set olRoot(1) = Application.Session.GetDefaultFolder(olFolderDrafts)
Set olRoot(2) = Application.Session.GetDefaultFolder(olFolderSentMail)
Set olRoot(3) = Application.Session.GetDefaultFolder(olFolderJunk)
Set olRoot(4) = Application.Session.GetDefaultFolder(olFolderDeletedItems)

For i = 0 To 4
On Error GoTo lbl_Exit
cFolders.Add olRoot(i)
Do While cFolders.Count > 0
Set olFolder = cFolders(1)
cFolders.Remove 1
DeleteItems olFolder.Items
For Each subFolder In olFolder.folders
cFolders.Add subFolder
Next subFolder
Loop
ClearCollection cFolders
Next i
lbl_Exit:
Set olFolder = Nothing
Set subFolder = Nothing
Set olRoot(4) = Nothing
Exit Sub
End Sub

Private Function DeleteItems(Outlook_Items As Items)
Dim i As Long
For i = (Outlook_Items.Count) To 1 Step -1
If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then
If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then
Outlook_Items.Item(i).Delete
End If
End If
Next i
lbl_Exit:
Exit Function
End Function

Private Sub ClearCollection(cCol As Collection)
Do Until cCol.Count = 0
cCol.Remove 1
Loop
lbl_Exit:
Exit Sub
End Sub

[nt1]

Strange but that did not delete anything at all. Set it to 0 to 3 and 0 to 4.

[nt1]

Any help. Is this possible

[gmayor]

To check whether the macro is evaluating your messages, add a message box to the following function as shown. You will then get a message box for each message processed that provides the message subject, the data difference and your archive test. If you get those messages and nothing is deleted, then no messages fit the criteria. My guess is that you need to take another look at the Archive test.

Private Function DeleteItems(Outlook_Items As Items)
Dim i As Long
For i = (Outlook_Items.Count) To 1 Step -1
MsgBox Outlook_Items.Item(i).Subject & vbCr & _
DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) & _
InStr(Outlook_Items.Item(i).Categories, "Archive")
If DateDiff("d", Outlook_Items.Item(i).CreationTime, Now) > 90 Then
If (InStr(Outlook_Items.Item(i).Categories, "Archive") = 0) Then
Outlook_Items.Item(i).Delete
End If
End If
Next i
lbl_Exit:
Exit Function
End Function

[nt1]

I am no expert at VBA but I do not know what you mean by "add a message box to the following function as shown". I copied and pasted your above scripts and nothing processes. Macros are turned on.

Please help. Is this even possible? It seems we can only macro the default folders. My original script does more.

Are you sure the above codes are correct no typo?

[gmayor]

I added the message box for you in my last post and yes the code is correct and works here - albeit I don't have any messages that accord to your 'categories' check and thus it doesn't delete any of the messages, but the box will report each message it checks.

[nt1]

I tried re pasting and the subfolders still have emails that data way longer than 90 days.
For categories I just created one called archive and coloured it black.

Only my default folders are deleting not any subfolders. grrrrr same problem.

I dont get a report btw. When I open Outlook I see the splash screen log saying updating plugins but thats it.

I placed the reporting code first and even tried last.

Any help will really be useful.

[gmayor]

Did you put all the code I posted originally in a module (not ThisOutlookSession)?
Did you replace the DeleteItems function with the revised version from my later post?
Did you delete or rename your original macro of the same name?
Add
Option Explicit to the top of the module, above any code.
What happens when you then run the macro 'RemoveEmail90'? You should see a message box for every message in the folders. If there are only two lines of text in the message boxes, the categories check from your original macro doesn't work.
If nothing happens, use SelfCert.exe in the Office program folder to create a personal certificate. Sign the VBA project using this certificate, then see http://answers.microsoft.com/en-us/office/forum/office_2013_release-customize/having-problems-with-selfcertexe/58874565-516f-4dbc-9b7f-a7471af3a941

[nt1]

The code seems to be working. This is great news and of course we are VERY Thankful!

Just a few questions...

Will this affect other inboxes in Outlook or just the primary? It doesn't seem to be affecting other inboxes just checking. We do not want that option so it looks good.

Also will this script affect pst files like local archived email?

Thanks again. Donations are coming ... woot!

[nt1]

Ok I noticed 1 small issue. The default folders and the "subfolders of inbox" are deleting fine. But if I create a new folder beside inbox not a sub, these emails do not get looked at.

[gmayor]

The macro affects only the named folders and their sub folders.

Application.Session.GetDefaultFolder(olFolderInbox)
Application.Session.GetDefaultFolder(olFolderDrafts)
Application.Session.GetDefaultFolder(olFolderSentMail)
Application.Session.GetDefaultFolder(olFolderJunk)
Application.Session.GetDefaultFolder(olFolderDeletedItems)

If you want more folders processed, you will have to add them e.g.


Set olRoot(0) = Application.Session.GetDefaultFolder(olFolderInbox)
Set olRoot(1) = Application.Session.GetDefaultFolder(olFolderDrafts)
Set olRoot(2) = Application.Session.GetDefaultFolder(olFolderSentMail)
Set olRoot(3) = Application.Session.GetDefaultFolder(olFolderJunk)
Set olRoot(4) = Application.Session.GetDefaultFolder(olFolderInbox).Parent.folders("FolderName")
Set olRoot(5) = Application.Session.GetDefaultFolder(olFolderDeletedItems)
where "FolderName" is the name of the folder on the same level as Inbox.

You will also have to increment the line

Dim olRoot(4) As Outlook.Folder to make it
Dim olRoot(5) As Outlook.Folder
and increment the loop
For i = 0 To 4 to account for the extra folder
For i = 0 To 5Repeat for any other folders at this level. Note also that the Deleted folders goes last so take account of its number.

[nt1]

So if I was going to use this script on say 10 users I would need to view their created parent folders to add the name. This can be inconvenient. Is there truly no way to loop through parent folders like you did the subfolders?

Or can we create a script that does not allow or deletes a created parent folder so that all mail is looked at?

[gmayor]

You can check any folders that you like and you can loop through any that are present, but it helps to know what you are dealing with before you start, rather than keep drip feeding more information.
Send a full specification of what you are doing to the contact link on my web site.

[nt1]

Sent you a contact form. :)

Thanks again!