Save attachments and create sub folders with the names of email subjects - vba

Question

I created a rule to move emails to sub folders called "outgoing" and "incoming comments". I need to extract the attachments into automatically created local hard drive sub folders named with the subjects of the emails.
The local drive is F:\Outgoing

Answer 1

Loop through the Folder.Items collection and get MailItem objects from each item in the collection. Then for each MailItem, call Attachment.SaveAsFile for each object in MailItem.Attachments.

Answer 2

Option Explicit
Const folderPath = "f:\outgoing\"
Sub GetOutGoingAttachments()
On Error Resume Next
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Dim Inbox As MAPIFolder
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Dim searchFolder As String
searchFolder = InputBox("Search for Outgoing Reports?")
Dim Subfolder As MAPIFolder
Dim Item As Object
Dim Attach As Attachment
Dim FileName As String
Dim i As Integer
If searchFolder <> "inbox" Then
Set Subfolder = Inbox.Folders(searchFolder)
i = 0
If Subfolder.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Subfolder.Items
For Each Attach In Item.Attachments
'
Attach.SaveAsFile (folderPath & Attach.FileName)
i = i + 1
Next Attach
Next Item
'==============================================================================
'to search specific type of file:
' 'For Each Item In Inbox.Items
' For Each Atmt In Item.Attachments
' If Right(Atmt.FileName, 3) = "xls" Then
' FileName = "C:\Email Attachments\" & Atmt.FileName
' Atmt.SaveAsFile FileName
' i = i + 1
' End If
' Next Atmt
' Next Item
'===============================================================================
Else
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
On Error Resume Next
For Each Item In Inbox.Items
For Each Attach In Item.Attachments
FileName = folderPath & Attach.FileName
Attach.SaveAsFile FileName
i = i + 1
Next Attach
Next Item
End If
End Sub