Download attachments from multiple sub folders of outlook from excel.

      Sub GetAttachments(MyMail As MailItem)
       On Error GoTo GetAttachments_err
       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("AutomationOutlook")
       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 Atmt In Item.Attachments
             FileName = "C:\OutlookAttachments\" & Atmt.FileName
             Atmt.SaveAsFile FileName
             i = i + 1
          Next Atmt
       Next Item
       If i > 0 Then
          MsgBox "I found " & i & " attached files." _
             & vbCrLf & "I have saved them into the C:\OutlookAttachments folder." _
             & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
       Else
          MsgBox "I didn't find any attached files in your mail.", vbInformation, _
          "Finished!"
      End If
      GetAttachments_exit:
         Set Atmt = Nothing
         Set Item = Nothing
         Set ns = Nothing
         Exit Sub
       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