CODEWITHSUNDEEP
vbaoutlook
Moataz Medhat
Moataz Medhat

Reputation: 1

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

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

Upvotes: 0

Views: 1477

Answers (2)

Brian
Brian

Reputation: 11

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

Upvotes: 1

Eric Legault
Eric Legault

Reputation: 5834

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.

Upvotes: 1

Related Questions