Option Explicit


Public Sub saveAttachtoDisk()  'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info_mail.ru совпадает с адресом отправителя
  
  Dim myItem As Outlook.MailItem
  Dim oFolder As Outlook.folder
  Dim Account As Outlook.NameSpace
  
  Dim a As Integer ' вспомогательная переменная для разных нужд
  Dim i As Integer ' вспомогательная переменная для разных нужд
  Dim f As Integer 'вспомогательная переменная для разных нужд
  
  Dim SenderMail As String 'переменная для обозначения имени отправителя из писем которого мы будем вытаскиваеть вложения и записывать из в папку на компьютере
  Dim Savefolder As String ' переменная для записи пути к папке , куда скидываем наши вложения из аутлука
  Dim AccountName As String ' переменная для записи имени Учетной записи в аутлуке, где мы ищем наши письма с вложениями
  
  
  SenderMail = "info_mail.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\info_mail.ru
  AccountName = "account_ya.ru" ' в этой учетной записи будем просматривать папки
  
  
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка info_mail.ru
    MkDir myFolder & SenderMail  ' и если папки info_mail.ru нет, то создаем её
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( D:\YandexDisk\YandexDisk\ папка info_mail.ru )
  
  'Debug.Print savefolder
  
  Set Account = Application.GetNamespace("MAPI") ' получаем доступ к учетным записям в аутлук
  'Set inboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' получаем коллекцию писем в папке Входящие (включая подпапки) в аутлук
  
  For f = 1 To Account.Folders.Count  ' пробегаем циклом по всем учетным записям в аутлуке
  If Account.Folders(f).Name = AccountName Then  ' если имя учетной записи равно AccountName , то
    Set oFolder = Account.Folders(f).Folders(11) ' получаем коллекцию писем в учетной записи AccountName в папке номер 11
  
    
    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
      If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
      Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
      
          If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то

                    For a = 1 To myItem.Attachments.Count
                      If myItem.Attachments.Item(a).fileName Like "*.xl*" Then
                            myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).fileName
                      End If
                    Next

          End If
       End If
    Next i
  End If
  Next f

  
End Sub



'Процедура показывает все учетные записи и все папки в них
Sub Учетки_и_папки()


   Dim x, xx
   Dim oNspace As Outlook.NameSpace
   Set oNspace = Application.GetNamespace("MAPI")
    For x = 1 To oNspace.Folders.Count
        Debug.Print oNspace.Folders(x).Name & " ==> " & x
        For xx = 1 To oNspace.Folders(x).Folders.Count
            Debug.Print vbTab & oNspace.Folders(x).Folders(xx).Name & " ==> " & xx
        Next
        Debug.Print "============== "
    Next
End Sub