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.
Code:
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