Saving Outlook Attachments - vba

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