Set oFolder = oNamespace.GetDefaultFolder(5)'SentMail
  Set oFolder = oNamespace.GetDefaultFolder(6)'Inbox

'СОХРАНЕНИЕ ВЛОЖЕНИЙ С РАСКЛАДКОЙ ПО ПАПКАМ
Sub Sohr_RogaiKopita()

Dim SchetAccauntov As Long 'инициализация переменной счетчика
Dim SchetPapok1Urov As Long 'инициализация переменной счетчика
Dim SchetPapok2Urov As Long 'инициализация переменной счетчика
Dim saveFolder As String
Dim Uchastok As String
Dim Zakazchik As String
'1.1 инициализация переменных писем вложений
Dim Vlogenie As Object 'Outlook.Attachment
Dim SpisokPisem As Object
Dim OtdPismo As Object
'1.2 инициализация переменных папок
Dim OlAPP As Object 'инициализация приложения Outlook
Dim PapkiAccauntov As Object 'инициализация переменной папок аккаунтов
Dim Ur1Papki As Object 'инициализация переменной папок 1 уровня
Dim Ur2Papki As Object 'инициализация переменной папок 2 уровня
Dim Ur3Papki As Object 'инициализация переменной папок 3 уровня

Application.ScreenUpdating = False 'отключаем обновление экрана, чтобы наши действия не мелькали
On Error Resume Next
Set OlAPP = GetObject(, "outlook.Application") 'подключаемся к Outlook
    If OlAPP Is Nothing Then
        Set OlAPP = CreateObject("outlook.Application")
        IsNotAppRun = True
    End If
Set PapkiAccauntov = OlAPP.GetNamespace("MAPI") 'присвоение переменной всех папок
saveFolder = "C:\Test\"

SchetAccauntov = PapkiAccauntov.Folders.Count 'Подсчёт аккаунтов
For i = 1 To SchetAccauntov 'Ограничиваем индексом перебор перебор аккаунтов
  Set Ur1Papki = PapkiAccauntov.Folders(i)
    If i = 1 Then 'мне нужен второй аккаунт
    SchetPapok1Urov = Ur1Papki.Folders.Count 'Подсчёт папок 1 уровня у меня это Участок
            For j = 1 To SchetPapok1Urov
                    If j = 13 Then 'j > 8 And j < 16 Then 'Ограничиваем индексом перебор папок 1 уровня у меня это Участок
                        Set Ur2Papki = Ur1Papki.Folders(j) 'Считывание имен папок 2 уровня
                        Uchastok = Ur2Papki.Name
                        saveFolderUchastok = saveFolder & Uchastok
                            If Dir(saveFolderUchastok, vbDirectory) = "" Then 'Проверка наличия папки Участка в папке "Test"
                              MkDir saveFolderUchastok
                            End If
                        SchetPapok2Urov = Ur2Papki.Folders.Count 'Подсчёт папок 2 уровня
                             For k = 1 To SchetPapok2Urov 'Ограничиваем индексом перебор папок 2 уровня у меня это Заказчик
                                 Set Ur3Papki = Ur2Papki.Folders(k) 'Считывание имен папок 3 уровня
                                 Zakazchik = Ur3Papki.Name
                                 If Zakazchik Like "Рога и Копыта" Then
                                 Debug.Print Zakazchik
                                 saveFolderZakazchik = saveFolderUchastok & "\" & Zakazchik
                                    If Dir(saveFolderZakazchik, vbDirectory) = "" Then 'Проверка наличия папки Заказчика в папке Участка
                                      MkDir saveFolderZakazchik
                                    End If
                                    Set SpisokPisem = Ur3Papki.Items 'Присваем переменной список писем из нужной папки
                                    Debug.Print Ur3Papki.Items.Count
                                    For Each OtdPismo In SpisokPisem 'Перебираем письма в списке
                                        For Each Vlogenie In OtdPismo.Attachments 'Перебираем вложения в перебираемых письмах
                                            If OtdPismo.ReceivedTime > (Date - 31) Then
                                            Debug.Print Vlogenie
                                            Debug.Print Format(OtdPismo.ReceivedTime, " YYYY.MM.DD  hh-mm-ss")
                                                If Vlogenie Like "*.x*" Then '  "*.xl*"
                                                Debug.Print Ur3Papki.Items.Index
                                                    Vlogenie.SaveAsFile saveFolderZakazchik & "\" & Format(OtdPismo.ReceivedTime, "YYYY.MM.DD  hh-mm-ss") & "_" & Vlogenie.Filename
                                                End If
                                            End If
                                        Next
                                    Next
                                    End If
                            Next
                    End If
            Next
    End If
Next
    If IsNotAppRun Then 'Если приложение Outlook было открыта кодом - закрываем
        objOutlApp.Quit
    End If
'очищаем переменные
Set OtdPismo = Nothing
Set SpisokPisem = Nothing
Set PapkiAccauntov = Nothing
Set OlAPP = Nothing
'возвращаем ранее отключенное обновление экрана
Application.ScreenUpdating = True
End Sub