Loop this code trough all folders in Outlook

zerlotus

New Member
Joined
Jul 3, 2017
Messages
15
Hello Everyone!

I've got to made this vba code which downloads attached files from mails that meet criteria to specified folder:
VBA Code:
Public Sub downloadifmatchcriteria()

    Dim olNs As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Outlook.MailItem
    Dim Atmt As Attachment
    Dim Filter As String
    Dim FilePath As String
    Dim AtmtName As String
    Dim Subject As String
    Dim i As Long


    Set olNs = Outlook.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    FilePath = "C:\users\zerlotus\Documents\Closing\"
    Filter = "[FlagRequest] = Follow Up"
    Set Items = Inbox.Items.Restrict(Filter)
    
Items.Sort "[ReceivedTime]"

  For Each Item In Items

        DoEvents


        If Item.Class = olMail And InStr(Item.Subject, "[Closing]") > 0 Then
          'Item.ClearTaskFlag
          'Item.UnRead = False
          DoEvents
          Item.Save

            For Each Atmt In Item.Attachments
                AtmtName = FilePath & Atmt.filename
                Atmt.SaveAsFile AtmtName
            Next
        End If
    Next
    

    Set Inbox = Nothing
    Set Items = Nothing
    Set Item = Nothing
    Set Atmt = Nothing
    Set olNs = Nothing
    
   
End Sub

It works great so far, but it only applies to main folder "Inbox". I've tried about everything in the net to "frankestein" my code but I couln't get it to work.


How would you apply this code to every single folder in Outlook account?


Thank you all,
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number

RayFrye

Board Regular
Joined
Jan 31, 2005
Messages
81
Office Version
  1. 365
  2. 2019
This will loop thru all the folders, modify as required.

Add:
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder

I didn't modify you code, but you get the general idea.

VBA Code:
Sub GetEmail()

Dim OutApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Mfolder As Outlook.MAPIFolder
Dim myMail As Outlook.Items

Dim Folder As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim UserFolder As Outlook.MAPIFolder

Set OutApp = New Outlook.Application
Set Namespace = OutApp.GetNamespace("MAPI")

On Error Resume Next
For Each Folder In Namespace.Folders
    For Each SubFolder In Folder.Folders
        For Each UserFolder In SubFolder.Folders
            Debug.Print Folder.Name, "|", SubFolder.Name, "|", UserFolder.Name
        Next UserFolder
    Next SubFolder
Next Folder
On Error GoTo 0

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,129,490
Messages
5,636,631
Members
416,932
Latest member
mm07

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top