How to extract attachments into a new subfolder per email?

Question

I'm trying to do this:

Public Sub saveAttachment(item As Outlook.MailItem)
Dim attachment As Outlook.Attachment
Dim defaultPath As String
defaultPath = "c:\Email Exports"
For Each attachment In itm.Attachments
    attachment.SaveAsFile defaultPath & "\" & attachment.DisplayName
    Set attachment = Nothing
Next
End Sub

...while also creating subfolders per email it extracts from.

Example. John Doe - Important files has two attachments.
Create a John Doe - Important files folder, and save the two attachments.

The default behavior is to save them as individual files but I would like them to be organized per email. I stumbled on ways to do the creation part, but it creates a folder per attachment and not per email.

Answer 1

It seems you need to check attachments number before creating a folder and iterating over all attachments.

Public Sub saveAttachment(item As Outlook.MailItem)
Dim attachment As Outlook.Attachment
Dim defaultPath As String
defaultPath = "c:\Email Exports"

  If itm.Attachments.Count > 0 Then
     Dim yourPath as String = MkDir "Ex. John Doe - Important files", defaultPath
     For Each attachment In itm.Attachments
          attachment.SaveAsFile yourPath "\" & attachment.DisplayName
          Set attachment = Nothing
     Next
  End If 
End Sub

You need to check if the folder exists. If not, then make it. This function does the job.

'requires reference to Microsoft Scripting Runtime
Function MkDir(strDir As String, strPath As String) as String

Dim fso As New FileSystemObject
Dim path As String

'examples for what are the input arguments
'strDir = "Folder"
'strPath = "C:\"

path = strPath & strDir

If Not fso.FolderExists(path) Then

' doesn't exist, so create the folder
          fso.CreateFolder path

End If

Return path

End Function

See How do I use FileSystemObject in VBA? for more information.