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!