'---------------------------------------------------------------------------------------
Sub SaveAttachedItemsFromOutlook()
    Dim objOutlApp As Object, oNSpace As Object, oIncoming As Object
    Dim oIncMails As Object, oMail As Object, oAtch As Object
    Dim IsNotAppRun As Boolean
    Dim sFolder As String, s As String
    Dim fld As Folder
    Const nameFolder = "test"
 
    
    
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    
    'подключаемся к Outlook
    On Error Resume Next
    Set objOutlApp = GetObject(, "outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("outlook.Application")
        IsNotAppRun = True
    End If
    'получаем доступ к папкам почты
    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    
      'подключаемся к папке Входящие, почтового ящика по умолчанию
      
    Set oIncoming = oNSpace.GetDefaultFolder(6).Folders(nameFolder)
    
    'Удаленные ==> GetDefaultFolder(3)
    'Исходящие ==> GetDefaultFolder(4)
    'Отправленные ==> GetDefaultFolder(5)
    'Входящие ==> GetDefaultFolder(6)
    
    'получаем коллекцию писем Входящие(включая подпапки)
    Set oIncMails = oIncoming.Items
    'просматриваем каждое письмо
   For Each oMail In oIncMails
       'просматриваем каждое вложение письма
      For Each oAtch In oMail.Attachments
           'отбираем только файлы Excel
           If oAtch Like "*.pdf*" Then
               s = GetAtchName(sFolder & oAtch)
             oAtch.SaveAsFile s
           End If
       Next
   Next    'Если приложение Outlook было открыта кодом - закрываем
    If IsNotAppRun Then
        objOutlApp.Quit
    End If
    'очищаем переменные
    Set oIncMails = Nothing
    Set oIncoming = Nothing
    Set oNSpace = Nothing
    Set objOutlApp = Nothing
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetShName
' Purpose   : Функция получения уникального имени файла
'             если файл с именем s уже есть - добавляет номер в скобках
'---------------------------------------------------------------------------------------
Function GetAtchName(ByVal s As String)
    Dim s1 As String, s2 As String, sEx As String
    Dim lu As Long, lp As Long
    
    s1 = s
    lp = InStrRev(s, ".", -1, 1)
    If lp Then
        sEx = Mid(s, lp)
        s1 = Mid(s, 1, lp - 1)
    End If
    s2 = s
    lu = 0
    Do While (Dir(s2, 16) <> "")
        lu = lu + 1
        s2 = s1 & "(" & lu & ")" & sEx
    Loop
    GetAtchName = s2
End Function