Сохранить вложения из Outlook в папку
Сегодня я хотел бы поделиться очередным решением с использованием 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 KiB, 3 491 скачиваний)
Макросы должны быть разрешены. Если не знаете что это такое - Что такое макрос и где его искать?
После запуска код попросит указать папку, в которую сохранять вложения. После этого все вложения, являющиеся файлами Excel, будут сохранены в указанную папку. Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).
Код имеет некоторые недостатки:
- нет возможности отобрать какие-то другие файлы, кроме Excel. Это легко исправить, если в строке If oAtch Like "*.xl*" Then вместо "xl*" указать нужное расширение. Например "
*.png " или "*.gif " - нет возможности выбрать папку для просмотра вложений - просматриваются абсолютно все письма папки Входящие учетной записи по умолчанию. Но можно указать только папку, отличную от Входящих: Удаленные, Исходящие, Отправленные - в коде есть комментарий с числовыми константами этих папок. Но в этих папках как правило вложения не просматривают
- и самый большой недостаток - нельзя выбрать учетную запись Outlook, для которой просматривать Входящие. Просмотр возможен исключительно в учетной записи, установленной по умолчанию
Именно из-за наличия такого количества недостатков я написал другой код - более сложный. Приводить в статье его не буду, т.к. он состоит из нескольких модулей и формы пользователя - проще будет скачать файл ниже и посмотреть. Вот как он выглядит в работе:
Как работает: скачиваете файл
Tips_GetOutlookAttach_Advanced.xls (91,5 KiB, 4 363 скачиваний)
После открытия файла нажимаете на кнопку и появляется форма(как на картинке выше).
В левом списке формы уже будут отображены все учетные записи Outlook. Необходимо выбрать нужную. После выбора учетной записи в правом списке отобразятся все папки, созданные для этой учетной записи в папке Входящие. Если выбрать одну или несколько папок, то будут просматриваться вложения исключительно в выбранных папках. Если ничего не выбрать - программа уточнит, действительно ли не планировалось выбирать ни одной папки и надо ли просматривать абсолютно все письма только в папке Входящие(исключая подпапки).
Просматривать все папки - если установлен, то вложения будут просматриваться во всех письмах папки Входящие(включая все подпапки).
Выберите папку для сохранения вложений - кнопкой справа от поля выбирается папка, в которую надо сохранить все найденные вложения.
Отбирать вложения - указываются маски для типов файлов, которые необходимо отбирать. По умолчанию установлена маска
После нажатия СОХРАНИТЬ ВЛОЖЕНИЯ внизу формы отобразится информационное окно, показывающее в какой папке идет поиск вложений и каков прогресс выполнения операции поиска в этой папке(на картинке это зеленая полоса внизу формы). Если имена каких-то вложений совпадают, то к имени файла в скобках добавляется номер (х).
В обоих кодах и файлах используется обращение к индексам папок, которые используются в 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
Статья помогла? Поделись ссылкой с друзьями!
Поиск по меткам
Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
Если это еще возможно, по прошествии лет, то не могли вы помочь донастроить модуль под мою проблему?
Мне надо чтобы все вложения как и здесь скидывались в одну папку, но в ней также раскидывались по папкам, чтобы каждое письмо в свою. Имена папкам просто номерами присваивать...
Низкий поклон автору, сэкономил такое количество времени на сохранении вложений - просто не передать.
Спасибо!
А можно сделать так чтобы файлы перезаписывались, а не сохранялись с новым именем?
Вячеслав, вместо строки
запишите просто:
У меня при запуске файла Advanced в окне, где нужно выбрать папку, не показывает мои папки. Подскажите, в чем может быть проблема?
входящие это не folders(2), а folders(4), надо поменять в коде в двух местах
Илья, у Вас неверные сведения :) В статье у меня указано не 2, а 6. Но и здесь есть нюанс: если была перестановка папок в Outlook, то и индекс может быть иным. И 4 и 5 и 11. Поэтому менять в коде чисто под Вашу ситуацию нет смысла. Просто допишу этот нюанс в статью, спасибо.
Плюс в карму, добрый человек. Работает.
При запуске Файла с Advanced-версией отображается только список учётных записей в Outlook, а вот спиоск папок не отображается. В результате программа просто не работает.
Мне удалось исправить код таким образом, чтобы он отображался к нужной учётной записи и нужной учётной папке к ней, и решил вопрос без формы: просто каждый раз подправляю код.
Подправьте, пожалуйста, код или сообщите, каким образом нужно донастроить параметры офиса (например, подключить какую-нибудь библиотеку), чтобы Ваш код работал.
Подскажите, какие изменения вы внесли в код?
Огромнейшее спасибо и низкий поклон!!
Замечательные макросы! Большое спасибо! можно еще прямо указывать вложенные папки
Set oIncoming = oNSpace.GetDefaultFolder(6).Folders("Имя папки")
Добрый вечер!
Все замечательно работает, спасибо большое!
Но есть необходимость, что бы сохраняла pdf файлы, это не проблема. Но только от конкретного отправителя (или определенной папки , куда все его письма перемещаются. Но не знаю индекс этой папки) Можно ли это сделать? Спасибо заранее!
Как сделать что бы он сохранял вложения от определенного отправителя? Или с писем из определенной папки (как узнать индекс папки)?
Эльдар, в конце статьи есть код, который позволяет узнать индексы папок. А адрес отправителя узнать совсем просто: за это отвечает свойство oMail.SenderEmailAddress