Saving Emails to New Folder along with Attachments

[thundercats9595]

Hello. I am hoping someone can lend me some assistance. I am very new to macros and I enjoy learning as much as can. I have pieced together the below and although my brain is hurting, I am beyond excited that I have it working!

The process handles individual emails well. It saves the email inside a newly created folder based of that emails subject name along with the attachments.

The goal is to process multiple emails. When I do, it saves the attachments randomly amongst the newly created folders. The emails themselves always end up in the right place but its the attachments that get scattered about.



Can someone help me with/understand more about the part for saving the attachments?

'Save All Attachments from Current Email and Save in Same Folder as Email

Thank you.

Sub SaveIntoFolders()
'this macro creates a Folder in a preset Path based off the email Subject line,
'then places the email in the Folder with the attachments.
Dim Mitem As Outlook.MailItem
Dim name As String
Dim Nname As String
Dim nFolder As String
Dim olkMsg As Object
Dim intIdx As Integer
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 Mitem = Outlook.ActiveExplorer.Selection.Item(1)
For Each Mitem In sln
If Mitem.Class = olMail Then
    If Nname = "" Then
    name = Mitem.Subject
    Else
    End If
' Cleanse illegal characters from subject... :/|*?<>" etc or sharepoint wont have it!
    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 & "\"
               'Create Folder = C:\Convert\FW Message Hello\
            MkDir nFolder
               'Save Email as C:\Convert\FW Message Hello\00_Email FW Message Hello.mht
            Mitem.SaveAs nFolder & "00_Email " & name & ".mht", olMHTML
               'Save All Attachments from Current Email and Save in Same Folder as Email
            For Each olkMsg In Application.ActiveExplorer.Selection
        For intIdx = olkMsg.Attachments.Count To 1 Step -1
            If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                olkMsg.Attachments.Item(intIdx).SaveAsFile nFolder & olkMsg.Attachments.Item(intIdx).FileName
            End If
        Next
        olkMsg.Close olDiscard
        Set olkMsg = Nothing
    Next
            End If
    Else
        MsgBox "You have not saved"
    End If
Next Mitem
End If
End Sub
Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
'Purpose: Determines if an attachment is embedded.'
'Written: 10/12/2010'
'Outlook: 2007'
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkAttachment.PropertyAccessor
IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
On Error GoTo 0
Set olkPA = Nothing
End Function

[thundercats9595]

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.

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

[thundercats9595]

Had to change a line to;

For Each ItemAttachment In itm.Attachments