I tried to change up the code to trouble shoot my issue. Same problem though. Works fine when processing a singe email, but when processing multiple ones, ALL of the selected email attachments are placed in all of the newly created folders. Each email ends up in the right folder though.
Assistance is truly needed. Thank you.
Code:
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