Delete old mails from the next 10 subfolders

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

Code:

---

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

---