Сегодня я хотел бы поделиться очередным решением с использованием Outlook. Задача сохранить все файлы Excel, хранящиеся как вложения, из папки Входящие(Inbox) на диск. Решение достигается только применением кода на VBA. Код ниже не имеет практически никаких настроек - он просто сохраняет абсолютно все вложения Excel из папки Входящие(включая подпапки):

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
    'диалог запроса выбора папки с файлами
    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)
    'Удаленные ==> 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 "*.xl*" 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 : GetAtchName
' 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

Код необходимо поместить в стандартный модуль и запустить. Или скачать приложенный ниже файл - там уже есть и кнопка для запуска:

  Tips_GetOutlookAttach.xls (54,0 КиБ, 3 561 скачиваний)


Макросы должны быть разрешены. Если не знаете что это такое - Что такое макрос и где его искать?

После запуска код попросит указать папку, в которую сохранять вложения. После этого все вложения, являющиеся файлами Excel, будут сохранены в указанную папку. Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).
Код имеет некоторые недостатки:

  • нет возможности отобрать какие-то другие файлы, кроме Excel. Это легко исправить, если в строке If oAtch Like "*.xl*" Then вместо "xl*" указать нужное расширение. Например "*.png" или "*.gif"
  • нет возможности выбрать папку для просмотра вложений - просматриваются абсолютно все письма папки Входящие учетной записи по умолчанию. Но можно указать только папку, отличную от Входящих: Удаленные, Исходящие, Отправленные - в коде есть комментарий с числовыми константами этих папок. Но в этих папках как правило вложения не просматривают
  • и самый большой недостаток - нельзя выбрать учетную запись Outlook, для которой просматривать Входящие. Просмотр возможен исключительно в учетной записи, установленной по умолчанию

Именно из-за наличия такого количества недостатков я написал другой код - более сложный. Приводить в статье его не буду, т.к. он состоит из нескольких модулей и формы пользователя - проще будет скачать файл ниже и посмотреть. Вот как он выглядит в работе:
Сохранить вложения из Outlook
Как работает: скачиваете файл

  Tips_GetOutlookAttach_Advanced.xls (91,5 КиБ, 4 442 скачиваний)


После открытия файла нажимаете на кнопку и появляется форма(как на картинке выше).
В левом списке формы уже будут отображены все учетные записи Outlook. Необходимо выбрать нужную. После выбора учетной записи в правом списке отобразятся все папки, созданные для этой учетной записи в папке Входящие. Если выбрать одну или несколько папок, то будут просматриваться вложения исключительно в выбранных папках. Если ничего не выбрать - программа уточнит, действительно ли не планировалось выбирать ни одной папки и надо ли просматривать абсолютно все письма только в папке Входящие(исключая подпапки).

Просматривать все папки - если установлен, то вложения будут просматриваться во всех письмах папки Входящие(включая все подпапки).

Выберите папку для сохранения вложений - кнопкой справа от поля выбирается папка, в которую надо сохранить все найденные вложения.

Отбирать вложения - указываются маски для типов файлов, которые необходимо отбирать. По умолчанию установлена маска "*.*" - отбирать все файлы. Однако можно указать любой тип файлов. Например, если указать "*.jpeg" - будут отобраны исключительно рисунки с расширением .jpeg. Если необходимо отбирать файлы более одного типа, то все маски можно перечислить через прямую черту - |. Например, чтобы отобрать все файлы Word, Excel и PowerPoint следует указать такую маску: "*.doc*|*.xl*|*.ppt*". Тут есть и еще один нюанс - таким образом можно указать маску не только форматов, но и имен файлов. К примеру, чтобы отобрать только файлы Excel, содержащие в имени слово "отчет" необходимо задать такую маску: "*отчет*.xl*".

После нажатия СОХРАНИТЬ ВЛОЖЕНИЯ внизу формы отобразится информационное окно, показывающее в какой папке идет поиск вложений и каков прогресс выполнения операции поиска в этой папке(на картинке это зеленая полоса внизу формы). Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).


В обоих кодах и файлах используется обращение к индексам папок, которые используются в Outlook по умолчанию:
Удаленные ==> GetDefaultFolder(3)
Исходящие ==> GetDefaultFolder(4)
Отправленные ==> GetDefaultFolder(5)
Входящие ==> GetDefaultFolder(6)

но здесь кроется маленький нюанс: порядок папок на некоторых ПК может отличаться(как правило это либо на серверных версиях, либо вследствие вмешательства в структуру папок). Поэтому, если отбор из папок не идет - можно попробовать найти нужную следующим кодом:

Sub FindIncomingFolder()
    Dim objOutlApp As Object, oNSpace As Object, i As Long
    On Error Resume Next
    Set objOutlApp = GetObject(, "outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("outlook.Application")
    End If
    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    For i = 1 To 50
        MsgBox i & " = " & oNSpace.GetDefaultFolder(i)
    Next
End Sub

Тогда достаточно будет запустить код и посмотреть какому номеру в показываемых сообщениях соответствует папка Входящие(Incoming).

Так же см.:
Сохранить вложения из Outlook
Как отправить письмо из Excel?
Вставить в письмо Outlook таблицу Excel с форматированием
Вставить в письмо подпись из Outlook через VBA
Как отправить письмо от другой учетной записи Outlook

Loading

20 комментариев

  1. Огромная благодарность за макрос. Подскажите, пож-та, как можно осуществлять закачивать вложения из папки "Входящие" только за определенную дату?

    1. Елена, надо будет добавить условие, вроде такого(внутрь цикла For Each oMail In oIncMails):
      If CDate(Int(oMail.ReceivedTime)) = #11/8/2021# Then
      End If

      т.е. должно получиться в итоге такое:
      'просматриваем каждое письмо
      For Each oMail In oIncMails
      If CDate(Int(oMail.ReceivedTime)) = #11/8/2021# Then
      'просматриваем каждое вложение письма
      For Each oAtch In oMail.Attachments
      'отбираем только файлы Excel
      If oAtch Like "*.xl*" Then
      s = GetAtchName(sFolder & oAtch)
      oAtch.SaveAsFile s
      End If
      Next
      End If
      Next

  2. Добрый день, Дмитрий!
    Огромное спасибо за ваш труд! Очень долго искала что-то подобное и нашла. И при этом все отлично работает, что бывает не всегда)).
    Очень нужен Вас совет, если позволите, т.к. столкнулась с несколькими проблемамии:
    1. Нет автоматической загрузки файлов в макросе. Т.е. он один раз выгрузил, но при обновлении аутлука, он не дозагружает файлы, которые, например, пришли на следующие дни. (у меня просто каждый день приходит много отчетов, которые нужно грузить в разные папки, чтобы потом power query автоматом их обрабатывал).
    2. В моем случае нужен фильтр для исключений. Т.к. мне приходят автоматические выгрузки с названиями, например:
    Отчет Леруа Мерлен за 01.12.2023, таблица.xls
    Отчет Леруа Мерлен за 01.12.2023, график.xls
    Это все в одном письме и график мне не нужен. Но я могу создать только правило "Отчет Леруа Мерлен", т.к. даты разные. И он грузит и таблицы и графики вместе. Т.е. нужно правило, по которому исключались бы файлы со словом "график".

    Подскажите, можно ли решить данные проблемы и к кому обратиться? заранее благодарна Вам.

    1. Ирина, решить-то можно, но в двух словах решение не опишешь. Здесь необходимо код дописывать(а может и вообще менять). Правда, с вопросом 1 не совсем понятно - то ли хотите автоматом при поступлении писем выгружать, то ли кодом из Excel.
      Если интересует решение на платной основе: напишите на info@excel-vba.ru - обсудим детали.
      Спасибо.

Добавить комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.