Sorting saved txt files on hard drive in folders based on date

[Legacial]

Hi guys,

I'm quite new to coding macros in Outlook using VBA so I have a slight problem. I wanted to save received emails in Outlook on my hard drive as text files, saving these files in monthly folders. So far, I have derived a macro that saves the emails on the hard drive as .txt files as below:
Sub Save_Mail_As_Text()
Dim itm As Object
Dim mFldr As Outlook.MAPIFolder
Dim mlItm As Outlook.MailItem
Dim strFileName As String

'Set mFldr = ThisOutlookSession.ActiveExplorer.CurrentFolder 'Use this to select current folder
Set mFldr = ThisOutlookSession.Session.PickFolder 'Use this to let user pick folder

If MsgBox("Are you sure you want to save all the emails from " & mFldr, vbYesNo) = vbNo Then GoTo End_Code

For Each itm In mFldr.Items
If itm.Class = olMail Then
strFileName = Left(Format(itm.ReceivedTime, "yyyy-mm-dd hh:mm:ss") & " - " & itm.SenderName & " - " & _
StripIllegalChar(itm.Subject), 256) & ".txt"
itm.SaveAs "C:\Users\Chigogo\Documents\Outlook_Email\Data\" & strFileName, olTXT
End If
Next itm

End_Code:
Set mFldr = Nothing

End Sub

Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")

RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True

StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing

End Function

Can this macro be modified so as to sort the files by date?? For example, if I were to receive an email today, it would go to the June_2011 folder on my hard drive. Any assistance would be highly appreciated. I also want it either to automatically create a new folder at the beginning of every month or save the files to a pre-created folder at the start of every month.

[JP2112]

I wasn't clear on the exact path, did you mean

C:\Users\Chigogo\Documents\Outlook_Email\Data\June_2011\

?

If so, you'll need to modify the code as follows:

Sub Save_Mail_As_Text()
Dim itm As Object
Dim mFldr As Outlook.MAPIFolder
Dim mlItm As Outlook.MailItem
Dim strFileName As String

'Set mFldr = ThisOutlookSession.ActiveExplorer.CurrentFolder 'Use this to select current folder
Set mFldr = ThisOutlookSession.Session.PickFolder 'Use this to let user pick folder

If MsgBox("Are you sure you want to save all the emails from " & mFldr, vbYesNo) = vbNo Then Goto End_Code

For Each itm In mFldr.Items
If itm.Class = olMail Then
strFileName = Left(Format(itm.ReceivedTime, "yyyy-mm-dd hh:mm:ss") & " - " & itm.SenderName & " - " & _
StripIllegalChar(itm.Subject), 256) & ".txt"
itm.SaveAs "C:\Users\Chigogo\Documents\Outlook_Email\Data\" & Format(Now,"mmm_yyyy") & "\" & strFileName, olTXT
End If
Next itm

End_Code:
Set mFldr = Nothing

End Sub

If you want to also create the folder then you'll need to do this as well:

Sub Save_Mail_As_Text()
Dim itm As Object
Dim mFldr As Outlook.MAPIFolder
Dim mlItm As Outlook.MailItem
Dim strFileName As String

'Set mFldr = ThisOutlookSession.ActiveExplorer.CurrentFolder 'Use this to select current folder
Set mFldr = ThisOutlookSession.Session.PickFolder 'Use this to let user pick folder

If MsgBox("Are you sure you want to save all the emails from " & mFldr, vbYesNo) = vbNo Then Goto End_Code

For Each itm In mFldr.Items
If itm.Class = olMail Then
strFileName = Left(Format(itm.ReceivedTime, "yyyy-mm-dd hh:mm:ss") & " - " & itm.SenderName & " - " & _
StripIllegalChar(itm.Subject), 256) & ".txt"
' check for folder and create if necessary
If Len(Dir("C:\Users\Chigogo\Documents\Outlook_Email\Data\" & Format(Now,"mmm_yyyy") & "\")) = 0 Then
MkDir "C:\Users\Chigogo\Documents\Outlook_Email\Data\" & Format(Now,"mmm_yyyy") & "\"
End If
itm.SaveAs "C:\Users\Chigogo\Documents\Outlook_Email\Data\" & Format(Now,"mmm_yyyy") & "\" & strFileName, olTXT
End If
Next itm

End_Code:
Set mFldr = Nothing

End Sub

(this is air code, please test it)