Sub SaveAttachments()
    On Error Resume Next

    ' (*1) Ścieżka do głownego foldera gdzie mają być zapisywane załączniki
    Dim strDestFolderPath
    strDestFolderPath = "C:\temp\attachments\"
    
    ' (*2) Jeśli chcesz usuwać zapisane załączniki, zmień wartość tej zmiennej na True
    Const bDeleteAttach = False
    
    
    ' (*3) Utwórz nowy folder o takiej samej nazwie jak folder w Outlook'u
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateFolder strDestFolderPath
    
    Dim oFolder As MAPIFolder
    Set oFolder = Application.ActiveExplorer.CurrentFolder
    
    strDestFolderPath = strDestFolderPath & oFolder.Name & "\"
    fso.CreateFolder strDestFolderPath
    
    
    ' Przetwarzaj wszystkie elementy w tym folderze
    For Each Item In Application.ActiveExplorer.Selection
    
        If Item.Attachments.Count > 0 And Item.UserProperties.Item("processed").Value <> 1 Then
            
            ' Tu będziemy zapamiętywać indeksy zapisanych załączników, żeby potem wiedzieć
            ' które usuwać
            ReDim arAttachIndexes(0) As Integer
            
            ' Zapisz wszystkie załączniki
            For Each attach In Item.Attachments
                Dim oAttach As Attachment
                Set oAttach = attach
                
                ' (*4)
                If oAttach.Type = olByValue Or oAttach.Type = olEmbeddeditem Then
                    
                    oAttach.SaveAsFile strDestFolderPath & oAttach.FileName
                    
                    ' Zapamiętaj index załącznika
                    ReDim Preserve arAttachIndexes(UBound(arAttachIndexes) + 1)
                    arAttachIndexes(UBound(arAttachIndexes)) = oAttach.Index
                End If
            Next
            
            If Not IsEmpty(arAttachIndexes) Then
            
                If bDeleteAttach Then
                    ' (*5) Usuń wszystkie zapisane wcześniej załączniki
                    For Index = UBound(arAttachIndexes) To 1 Step -1
                        Dim att: Set att = Item.Attachments(arAttachIndexes(Index))
                        att.Delete
                    Next
                End If
                
            End If
            
            ' (*6) Oznacz jako przetworzony
            Item.UserProperties.Add "processed", olNumber
            Item.UserProperties.Item("processed").Value = 1
            Item.Save
            
        End If
        
    Next

End Sub