Save Outlook Attachemnts1.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(File_Saved, Trim(olMail.Subject)))
        
           For Each olAttachment In olMail.Attachments

                olAttachment.SaveAsFile fso.BuildPath(File_Saved, Trim(olMail.Subject)) & "\" & olAttachment.FileName        
                
           Next olAttachment
            
        End If
        
    Next olMail
    
    Set olFolder_Inbox = Nothing
    Set fso = Nothing
    Set ns = Nothing
    
End Sub