Save Outlook Attachemnts2.bas

Sub Download_Attachments()
    
    Dim ns As NameSpace
    Dim olFolder_Inbox As Folder
    Dim olMail As MailItem
    Dim olAttachment As Attachment
    
    Dim fso As Object
    Dim Files_Saved_Folder_Path As String
    
    Files_Saved_Folder_Path = "<Your folder path>"
    
    Set ns = GetNamespace("MAPI")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox)
    
    For Each olMail In olFolder_Inbox.Items
        
        If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
            
           fso.CreateFolder (fso.BuildPath(Files_Saved_Folder_Path, Trim(olMail.Subject)))
        
           For Each olAttachment In olMail.Attachments
           
                Select Case UCase(fso.GetExtensionName(olAttachment.FileName))
                    
                    Case "XLSX", "XLSM"
                        olAttachment.SaveAsFile fso.BuildPath(Files_Saved_Folder_Path, Trim(olMail.Subject)) & "\" & olAttachment.FileName
                    
                    Case "JPEG", "PNG", "JPG"
                        'olAttachment.SaveAsFile fso.BuildPath(Files_Saved_Folder_Path, Trim(olMail.Subject)) & "\" & olAttachment.FileName
                        
                    Case Else
                        'skip
                        
                End Select

           Next olAttachment
            
        End If
        
    Next olMail
    
    Set olFolder_Inbox = Nothing
    Set fso = Nothing
    Set ns = Nothing
    
End Sub