Saving Outlook Attachments

Question

working with VBA in Outlook and am struggling with levelled folders when locating as it seems to only work a one levelled 'sub level'. I currently have probably a 5 tier folder organisation in my outlook, and daily I will get many emails which have attachments that need to be filed. So far I'm working with my first folder to extract attachments and file them in a designated folder I have made but it wont work as the subfolder is in the 4th tier.

Sub GetAttachments()
On Error GoTo GetAttachments_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
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("DZ1")
    i = 0
' Check Inbox for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
   MsgBox "There are no messages in the Sales Reports folder." _
   , vbInformation, "Nothing Found"
   Exit Sub
End If
' Check each message for attachments
    If SubFolder.Items.Count > 0 Then
    For Each Item In SubFolder.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
            FileName = "File path" & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_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 GetAttachments_exit
End Sub

Can I please get some help?

Cheers

Answer 1

You need to refactor your code so that the operations that are performed in a folder is in a recursive method that calls itself when it needs to access another folder in the folder's Folder.Folders collection.

Answer 2

Follow the path as if you were getting the folder manually.

Set SubFolder = Inbox.Folders("DZ1").Folders("DZ2").Folders("DZ3").Folders("DZ4")

Answer 3

just searching subfolders will reeally only check direct subfolders. not "grandchildren".

You would have to do something like:

Sub subfolderrs_6_levels()
   Dim Ol, Mf, Mf1, mf2, Ns, mf3, mf4, mf5, mf6, I&
   On Error Resume Next
   For Each Mf In Ns.Folders
      call_your_routine(mf)
      I = I + 1
      For Each Mf1 In Mf.Folders
          call_your_routine(mf1)
      I = I + 1
         For Each mf2 In Mf1.Folders
           call_your_routine(mf2)
      I = I + 1
            For Each mf3 In mf2.Folders
            call_your_routine(mf3)
      I = I + 1
            For Each mf4 In mf3.Folders
            call_your_routine(mf4)
      I = I + 1
            For Each mf5 In mf4.Folders
            call_your_routine(mf5)
      I = I + 1
            For Each mf6 In mf5.Folders
            call_your_routine(mf6)
            Next
            Next
            Next
            Next
         Next
      Next
   Next
   Set Ns = Nothing: Set Mf1 = Nothing: Set Mf = Nothing: Set Ol = Nothing: 
   Set mf2 = Nothing: Set mf3 = Nothing: Set mf4 = Nothing: Set mf5 = Nothing: Set mf6 = Nothing
End Sub

sub call_your_routine(mf as Outlook.folder)
    For Each Item In SubFolder.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
            FileName = "File path" & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
end sub