Archive Mail Macro for Outlook VBA

Something I quickly knocked up to tidy up my mailbox, don't know if it might be useful. you need a folder called "Archive" under you mail inbox for this to work.


Sub archiveIT()

Dim diff: diff = CInt(InputBox("Enter total number of day to retain", "Archive Mail", 7))
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim Destination As MAPIFolder

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set Destination = myInbox.Folders("Archive")

Dim msg As MailItem
For x = myInbox.Items.Count To 1 Step -1
Set msg = myInbox.Items(x)
If msg.FlagIcon = olNoFlagIcon Then
If Abs(DateDiff("d", msg.ReceivedTime, DateTime.Now)) > diff Then
msg.Move Destination
End If
End If
Next
End Sub