Sub SaveIntoFoldersNew()
Dim Item As Object
Dim itm As Outlook.MailItem
Dim name As String
Dim Nname As String
Dim nFolder As String
Dim strFileName As String
Dim ItemsCount As Long
Dim ItemsAttachmentsCount As Long
Dim iSave As Long
Dim msg As String
Dim intIdx As Integer
Dim excApp As Object
Dim Exp As Outlook.Explorer
Dim sln As Outlook.Selection
 
 
   Set Exp = Application.ActiveExplorer
   Set sln = Exp.Selection
   If sln.Count = 0 Then
   MsgBox "No objects selected."
   Else
   myPath = "C:\Convert"
 
   Set itm = Outlook.ActiveExplorer.Selection.Item(1)
 
   For Each itm In sln
 
 
   If itm.Class = olMail Then
       If Nname = "" Then
       name = itm.Subject
       Else
 
       End If
' Cleanse illegal characters from subject... :/|*?<>" etc
       name = Replace(name, "<", "(")
       name = Replace(name, ">", ")")
       name = Replace(name, "&", "n")
       name = Replace(name, "%", "pct")
       name = Replace(name, """", "'")
       name = Replace(name, "´", "'")
       name = Replace(name, "`", "'")
       name = Replace(name, "{", "(")
       name = Replace(name, "[", "(")
       name = Replace(name, "]", ")")
       name = Replace(name, "}", ")")
       name = Replace(name, "  ", "_")
       name = Replace(name, "   ", "_")
       name = Replace(name, "  ", "_")
       name = Replace(name, "..", "_")
       name = Replace(name, ".", "_")
       name = Replace(name, "__", "_")
       name = Replace(name, ": ", "_")
       name = Replace(name, ":", "_")
       name = Replace(name, "/", "_")
       name = Replace(name, "\", "_")
       name = Replace(name, "*", "_")
       name = Replace(name, "?", "_")
       name = Replace(name, """", "_")
       name = Replace(name, "__", "_")
       name = Replace(name, "|", "_")
 
 
           If myPath = False Then
               MsgBox "No directory chosen !", vbExclamation
           Else
 
               nFolder = myPath & "\" & name & "\"
               MkDir nFolder
 
               itm.SaveAs nFolder & "00_Email " & name & ".mht", olMHTML
 
For iSave = 1 To ActiveExplorer.Selection.Count
 
   Set Item = ActiveExplorer.Selection(iSave)
 
If TypeOf Item Is MailItem Or TypeOf Item Is PostItem Then
       ItemsCount = ItemsCount + 1
       For Each ItemAttachment In Item.Attachments
           ItemsAttachmentsCount = ItemsAttachmentsCount + 1
           ' Get the file name.
           strFileName = ItemAttachment.FileName
 
           ' Save the attachment as a file.
           ItemAttachment.SaveAsFile nFolder & strFileName
       Next ItemAttachment
 
   End If
 
 
           Item.Close olDiscard
           Set Item = Nothing
       Next
 
 
           End If
       Else
           MsgBox "You have not saved"
       End If
 
  Next itm
 
 End If
End Sub