On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim objItem
Dim myFolder
Dim strSubject
Dim strName
Dim strFile
Dim strReceived
Dim strSavePath

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set ofChosenFolder = myNameSpace.PickFolder


'get path to My Docs
Dim szDocsFolder, g_shell
Set g_shell = CreateObject("WScript.Shell")
szTempFolder = g_shell.SpecialFolders("MyDocuments")

'Get the current Username
Set WshNetwork = WScript.CreateObject("WScript.Network")
strUser = WshNetwork.UserName 

strSavePath = InputBox("Please enter the path to save to and be sure to end with a backslash at the end of your path. You can enter a new folder name if you like and it will be created", "Save Emails To:", szTempFolder & "\Saved Emails\" & ofChosenFolder & "\")

If not right(strSavePath,1) = "\" then
strSavePath = strSavePath & "\"
wscript.echo "You forgot a backslash at the end of your path." & vbcrlf & "But don't worry, I added one for you."
End If

' strSavePath = strSavePath & ofChosenFolder & "\"

strSaveFolder = Left(strSavePath, Len(strSavePath)-1)

If Not objFSO.FolderExists(strSaveFolder) then
if MsgBox("The folder you specified does not exist." & vbcrlf & "Would you like one created?", VBYesNo, "Folder Not Found") = 7 then
wscript.echo "Exiting script. Try again."
Else
objFSO.CreateFolder(strSaveFolder)
wscript.echo strSaveFolder & " - Created"
End if
End if


i = 1
For each Item in ofChosenFolder.Items
Set myItem = ofChosenFolder.Items(i)
strReceived = ArrangedDate(myitem.ReceivedTime)
' strSubject = myItem.Subject
strSubject = myitem.SenderName & "_" & myitem.Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
myItem.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
i = i + 1
next



Function StripIllegalChar(strInput)

'***************************************************
'Simple function that removes illegal file system
'characters.
'***************************************************

Set RegX = New RegExp

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

StripIllegalChar = RegX.Replace(strInput, "")
Set RegX = nothing

End Function


Function ArrangedDate(strDateInput)

'***************************************************
'This function re-arranges the date data in order
'for it to display in chronilogical order in a
'sorted list in the file system. It also removes
'illegal file system characters and replaces them
'with dashes.
'Example:
'Input: 2/26/2004 7:07:33 AM
'Output: 2004-02-26_AM-07-07-33
'***************************************************

Dim strFullDate
Dim strFullTime
Dim strAMPM
Dim strTime
Dim strYear
Dim strMonthDay
Dim strMonth
Dim strDay
Dim strDate
Dim strDateTime
Dim RegX

If not Left(strDateInput, 2) = "10" Then
If not Left(strDateInput, 2) = "11" Then
If not Left(strDateInput, 2) = "12" Then
strDateInput = "0" & strDateInput
End If
End If
End If

strFullDate = Left(strDateInput, 10)

If Right(strFullDate, 1) = " " Then
strFullDate = Left(strDateInput, 9)
End If

strFullTime = Replace(strDateInput,strFullDate & " ","")

If Len(strFullTime) = 10 Then
strFullTime = "0" & strFullTime
End If

strAMPM = Right(strFullTime, 2)

strTime = strAMPM & "-" & Left(strFullTime, 8)

strYear = Right(strFullDate,4)

strMonthDay = Replace(strFullDate,"/" & strYear,"")

strMonth = Left(strMonthDay, 2)

strDay = Right(strMonthDay,len(strMonthDay)-3)

If len(strDay) = 1 Then
strDay = "0" & strDay
End If

strDate = strYear & "-" & strMonth & "-" & strDay

'strDateTime = strDate & "_" & strTime
strDateTime = strDate

Set RegX = New RegExp

RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True

ArrangedDate = RegX.Replace(strDateTime, "-")

Set RegX = nothing

End Function