How to auto copy emails to file folder after x days on daily basis

[winxmun]

Hi, I am new to Outlook VBA.
I have been browsing internet on how to auto copy every emails to file folder after x days on a daily basis. In addition, to add "ddmmmyyy hhmm" in front of every emails that were copied into the file folder location.
Hope to receive help soon. Thanks in advance!

[gmayor]

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

[winxmun]

Hi gmayor, thank you so much for the code. appreciates it!