The following macro will do that (you can change the date switch as required, and the path where you wish to save the files). The macro calls functions to ensure that saved names are unique and do not include illegal filename characters.
Option Explicit
Sub ProcessMessages()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Set olItems = Session.GetDefaultFolder(olFolderInbox).Items
For Each olItem In olItems
If CDate(olItem.SentOn) < Date - 10 Then
'MsgBox CDate(olItem.SentOn) & vbCr & Date - 10
SaveMessage olItem
End If
Next olItem
Set olItem = Nothing
Set olItems = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub SaveMessage(olItem As MailItem)
Dim Fname As String
Dim fPath As String
fPath = "C:\Path\" 'the path where you wish to save the messages
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveUnique olItem, fPath, Fname
lbl_Exit:
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function