Сегодня я хотел бы поделиться очередным решением с использованием 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, для которой просматривать Входящие. Просмотр возможен исключительно в учетной записи, установленной по умолчанию
Именно из-за наличия такого количества недостатков я написал другой код - более сложный. Приводить в статье его не буду, т.к. он состоит из нескольких модулей и формы пользователя - проще будет скачать файл ниже и посмотреть. Вот как он выглядит в работе:
Как работает: скачиваете файл
Tips_GetOutlookAttach_Advanced.xls (91,5 КиБ, 4 442 скачиваний)
После открытия файла нажимаете на кнопку и появляется форма(как на картинке выше).
В левом списке формы уже будут отображены все учетные записи 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
Огромная благодарность за макрос. Подскажите, пож-та, как можно осуществлять закачивать вложения из папки "Входящие" только за определенную дату?
Елена, надо будет добавить условие, вроде такого(внутрь цикла 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
Подскажите пожалуйста, как можно так же вытащить файл с outlook,только с сетевой папки. Не входящие а в сетевой папке в outlook ?
Добрый день, Дмитрий!
Огромное спасибо за ваш труд! Очень долго искала что-то подобное и нашла. И при этом все отлично работает, что бывает не всегда)).
Очень нужен Вас совет, если позволите, т.к. столкнулась с несколькими проблемамии:
1. Нет автоматической загрузки файлов в макросе. Т.е. он один раз выгрузил, но при обновлении аутлука, он не дозагружает файлы, которые, например, пришли на следующие дни. (у меня просто каждый день приходит много отчетов, которые нужно грузить в разные папки, чтобы потом power query автоматом их обрабатывал).
2. В моем случае нужен фильтр для исключений. Т.к. мне приходят автоматические выгрузки с названиями, например:
Отчет Леруа Мерлен за 01.12.2023, таблица.xls
Отчет Леруа Мерлен за 01.12.2023, график.xls
Это все в одном письме и график мне не нужен. Но я могу создать только правило "Отчет Леруа Мерлен", т.к. даты разные. И он грузит и таблицы и графики вместе. Т.е. нужно правило, по которому исключались бы файлы со словом "график".
Подскажите, можно ли решить данные проблемы и к кому обратиться? заранее благодарна Вам.
Ирина, решить-то можно, но в двух словах решение не опишешь. Здесь необходимо код дописывать(а может и вообще менять). Правда, с вопросом 1 не совсем понятно - то ли хотите автоматом при поступлении писем выгружать, то ли кодом из Excel.info@excel-vba.ru - обсудим детали.
Если интересует решение на платной основе: напишите на
Спасибо.