Add email subject to file name when saving attachment - vba

Question

My goal is to extract the .png files of emails in the Outlook Inbox sub folder named Infuse Energy Daily Usage Reports.
The emails each contain six png files. The largest is the only one I need; it is exactly 37.6KB. The next largest file is 22.5KB. The third largest is 18.2KB.
The code mostly does what I need.
I want to add the full subject of the email to the beginning of the file name.
The file name should be:
"Email Subject, Creation Time ("yyyymmdd_hhnnss_"), Original File Name of PNG Image."
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Infuse Eneregy Daily Usage Reports" folder) for messages with attached
' files of a specific type (here file with a "png" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Infuse Energy Daily Usage Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit if none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Infuse Energy Daily Usage folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "png" extension
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the Infuse Reports (from email)." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Desktop\Energy Comparisons\Infuse Reports (from email)", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub

Answer 1

First of all, there is no need to iterate over all items in a folder:
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
This is not really a good idea because it can take a lot of time to iterate over all items in a folder. Instead, you need to use the Find/FindNext or Restrict methods of the Items class. Filter Example: [Attachment & Subject Like '%keyword%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%keyword%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
As for the filename of attachments saved to the disk, you need to make sure there are no forbidden symbols included to the filename before calling the SaveAsFile method.
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & Item.Subject & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Also be aware, an Outlook folder may contain different kind of items. I'd suggest checking the item's type at runtime to make sure you deal with mail items only. The Class property returns an OlObjectClass constant indicating the object's class. Or just use the following condition:
If TypeOf Item Is MailItem Then
' your code here
End If