Delete old mails from the next 10 subfolders

[Borg78]

Hi

I have this code which deletes mail older than 4 years from current folder (subfolder), but I'd like to expan it to current plus the next 5 or 10 folders, any ideas?

It's a shared folder, if that makes any differents


Sub DeleteOld()
Dim d As Date
d = Now() - (365 * 4) ' days
Set Items = ThisOutlookSession.ActiveExplorer.CurrentFolder.Items
Dim f As String
f = "([ReceivedTime] <= '" & Day(d) & "-" & Month(d) & "-" & Year(d) & "')"
Set Item = Items.Find(f)
While Not (Item Is Nothing)
Item.Delete
Set Item = Items.FindNext
Wend
End Sub