Sub SaveAsDocFolder()

Dim myolApp As Outlook.Application
Dim Item As Object

Dim dtDate As Date
Dim sName As String
Dim strFolderName As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")


Set myolApp = CreateObject("Outlook.Application")
Set mail = myolApp.ActiveExplorer.CurrentFolder

For Each Item In mail.Items
    Item.BodyFormat = olFormatRichText

'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
   ' Item.Save

sName = Item.Subject
ReplaceCharsForFileName sName, "_"

dtDate = Item.receivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName
    
'save to folder of same name
strFolderName = Item.Parent
Debug.Print strFolderName
strFolderpath = enviro & "\Documents\" & strFolderName & "\"
Debug.Print strFolderpath
If Not fso.FolderExists(strFolderpath) Then
    fso.CreateFolder (strFolderpath)
End If

Item.SaveAs strFolderpath & sName & ".doc", olRTF

Next Item

End Sub

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
  sName = Replace(sName, "&", sChr)
  sName = Replace(sName, "%", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, " ", sChr)
  sName = Replace(sName, "{", sChr)
  sName = Replace(sName, "[", sChr)
  sName = Replace(sName, "]", sChr)
  sName = Replace(sName, "}", sChr)
End Sub