Автоматическое копирование вложений из писем в папку

4 февраля 2012, VBA, Konstantin

Для автоматического копирования вложений из приходящих в Outlook писем в указанную папку можно воспользоваться правилом, исполняющим ниже прописанный скрипт VBA. Скрипт также модифицирует имя файла в соответствии с датой создания письма. Вариант из примера работает корректно для писем с одним вложением. Для писем с несколькими вложениями нужно изменить код в месте формирования имени файла.

В Outlook откройте окно VBA. Можно воспользоваться сочетанием Alt + F11.
Вставьте код, прописанный ниже, в раздел Modules. Слева найдите Modules. Если там нет раздела нет пункта Module, то создайте такой правым щелчком мыши по Modules. Или нажмите правой кнопкой по Modules, Insert -> Module.
Скопируйте код в главное окно.
Закройте VBA IDE.
Создайте правило, вызывающее скрипт.
В первом окне мастера создания нового правила выберите проверку входящих писем.
В следующем окне выберите правила отбора писем.
В третьем окне выберите «выполнить скрипт» (или «запустить скрипт»). Когда нажмете на подчеркнутое слов «скрипт», должен быть виден код, который был вставлен в консоль VBA.
Нажмите «Завершить» и проверьте работу правила.

Код:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
saveFolder = "C:\\Test"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
For Each objAtt In itm.Attachments
'Проверяем наличие файла с таким же именем
j = " "
  For i = 1 To 1000
   If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
    j = "_" & i & "_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & objAtt.FileName
Set objAtt = Nothing
Next
End Sub

Решение проблем

Если часть созданного правила выполняется, но сам скрипт не срабатывает, то, возможно, дело в настройках безопасности Outlook 2010/2013/2016 (в Outlook 2007 и старше эта опция находится в Tools -> Macro Security). Чтобы макрос сработал:

Откройте вкладку «Файл» (File), выберите настройки (Outlook Options) -> настройки безопасности (Trust Center).
Нажмите на настройки центра безопасности (Trust Center Settings), затем на настройки макросов слева (Macro Settings)
Выберите вариант уведомления обо всех макроса (Notifications for all macros) и нажмите OK. Это позволит выполнять макросы, но предварительно будет появляться сообщение об их запуске.

Обработка msg-вложений

Ниже пример кода, который сохраняет каждое вложение из письма в папку с названием, совпадающим с темой письма. Если вложенные файлы сами являются письмами (т.е. имеют расширение *.msg), то сохраняются только вложения из них в подпапку с названием таким же, как тема вложенного *.msg файла.
Чтобы код работал нужно включить Microsoft Scripting Runtime как описано в другой статье.

Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim objAttachments As Outlook.Attachment
Dim saveFolder As String
Dim openMsg As MailItem
 
dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
saveFolder = "C:\Test\"
If Dir(saveFolder, vbDirectory) = "" Then
  MkDir saveFolder
End If
For t = 1 To Len(itm.Subject)
  s = Mid(itm.Subject, t, 1)
  If Not LCase(s) Like "[?/\|*<>:]" Then
    sSubject = sSubject & s
  End If
Next t
 
For Each objAtt In itm.Attachments
saveFolderFull = saveFolder & sSubject
If Dir(saveFolderFull, vbDirectory) = "" Then
  MkDir saveFolderFull
End If
 
'Проверяем наличие файла с таким же именем
j = " "
  For i = 1 To 1000
   If Not Dir(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
    j = "_" & i & "_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
objAtt.SaveAsFile saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName
'Из msg файлов достаём вложения и удаляем
If LCase(Right(objAtt.FileName, 4)) = ".msg" Then
   Set openMsg = Application.CreateItemFromTemplate(saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName)
   sSubject2 = ""
   For t = 1 To Len(openMsg.Subject)
    s = Mid(openMsg.Subject, t, 1)
    If Not LCase(s) Like "[?/\|*<>:]" Then
     sSubject2 = sSubject2 & s
    End If
   Next t
   If Dir(saveFolderFull & "\" & sSubject2, vbDirectory) = "" Then
     MkDir saveFolderFull & "\" & sSubject2
   End If
   'Сохраняем вложения из msg-файла
   For Each objAttachments In openMsg.Attachments
     objAttachments.SaveAsFile saveFolderFull & "\" & sSubject2 & "\" & dateOfMailItem & objAttachments.FileName
     Next
  openMsg.Close olDiscard
  Kill saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName 'Удаляем файл msg-файла
End If
Set objAtt = Nothing
Next
End Sub

Сохранение письма с вложениями на диск

Если нужно сохранить само письмо, а не только вложения, то код упрощается:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
'Public Sub saveAttachtoDisk()
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim t As Integer
Dim s As String
Dim sSubject As String
 
'Dim itm As Outlook.MailItem
'Set itm = Application.ActiveExplorer().Selection(1)
 
saveFolder = "C:\Test"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
 
'Удаление недопустимых символов из темы
For t = 1 To Len(itm.Subject)
  s = Mid(itm.Subject, t, 1)
  If Not LCase(s) Like "[?/\|*<>:]" Then
    sSubject = sSubject & s
  End If
Next t
 
'Проверяем наличие файла с таким же именем
j = ""
  For i = 1 To 1000
   If Not Dir(saveFolder & "\" & j & sSubject & ".msg") = "" Then
    j = "(" & i & ")_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
 
'Сохранение вложения
itm.SaveAs (saveFolder & "\" & j & sSubject & ".msg")
 
End Sub

Полезные ссылки

Rule to automatically save attachment in Outlook — другой пример
MailItem Object (Outlook)

140 комментариев в “Автоматическое копирование вложений из писем в папку”

NN:

7 февраля 2013 в 9:03

Добрый день!
Макросы знаю не очень :). Но зато очень много приходит писем в экселе. Сделала все как написано. Но ничего не сохраняется и вот эта срочка красная:
objAtt.SaveAsFile saveFolder & «\Имя » & dateOfMailItem & «.xls». Я так понимаю, что-то надо сделат с «\Имя »
Скажите, пожалуйста, что мне надо исправить (Outlook и Excel — 10).
И еще здесь поменяла с saveFolder = «C:\Test\» на saveFolder = «D:\Test\»

Ответить
- Konstantin:
  
  7 февраля 2013 в 16:44
  
  Здесь saveFolder — это путь к папке, куда будет сохраняться файл, а “\Имя ” & dateOfMailItem & “.xls” — название xls файла с которым его нужно сохранить.
  
  Ответить
NN:

7 февраля 2013 в 13:39

я разобралсь

Ответить
Антон:

23 мая 2013 в 8:00

А как сохранять C:\mail\отправитель\data\имя вложения.xls
оч надо плизз

Ответить
- Konstantin:
  
  4 июня 2013 в 17:38
  
  Попробуйте так:
  For Each objAtt In itm.Attachments "C:mail" & objAtt.SenderName & "data" & objAtt.FileName
  For Each objAtt In itm.Attachments "C:mail" & objAtt.SenderName & "data" & objAtt.FileName
  Ответить
Николай:

17 июля 2013 в 10:52

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

Ответить
- Konstantin:
  
  22 августа 2013 в 19:13
  
  Тема письма хранится в свойстве Subject. Т.е. надо заменить строку
  objAtt.SaveAsFile saveFolder & "Имя " & dateOfMailItem & ".xls"
  objAtt.SaveAsFile saveFolder & "Имя " & dateOfMailItem & ".xls"
  на
  objAtt.SaveAsFile saveFolder & "" & itm.Subject & ".xls"
  objAtt.SaveAsFile saveFolder & "" & itm.Subject & ".xls"
  По поводу создания кнопки можно посмотреть вот этот материал, раздел «Кнопка на панели инструментов в Excel 2003 и старше».
  
  Ответить
Владимир:

4 сентября 2013 в 21:08

День добрый!
А можете подсказать? Как сохранить вложения, которые отвечают заданым критериям (например вложения типа «Прайс-001-05.09.2013.xls», где критерии слово «Прайс» и дата в названии файла) из всех непрочитаных писем. То есть макрос должен работать не постоянно, а только после нажатии кнопки анализировать непрочитаные письма и вложения. Если из какого-либо письма вложение сохраняется, письмо нужно сделать прочитаным.
заранее спасибо!

Ответить
- Konstantin:
  
  1 ноября 2015 в 19:56
  
  Мне кажется, что проще всего будет создать правило для писем со вложением. И выполнять скрипт в этом правиле. А чтобы сохранять только файл, с определённым названием, добавьте условие типа If InStrRev(UCase(objAtt.FileName), «ПРАЙС»)
  
  Ответить
Станислав:

15 октября 2013 в 12:14

Добрый день! установил правило и скрипт, вложения сохраняет, но сохраненный файл открыть не могу, пишет для файла *.docx «не удается открыть файл из-за проблем с его содержимым», а для файла *.xls «действительный формат открываемого файла отличается от указываемого его расширением имени файла»
Примечение: у меня office 2010

Ответить

Станислав:

16 октября 2013 в 4:46

Добрый день Константин! отправляю примеры файлов. В принципе такая ситуация со всеми файлами, даже с txt.
прописанный макрос:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
dateOfMailItem = Format(itm.CreationTime, "dd.mm.yyyy")
saveFolder = "C:Test"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "привет" & dateOfMailItem & ".txt"  ' здесь расширение менял на docx, xlsx, txt
Set objAtt = Nothing
Next
End Sub

Open Notes

Обо всём, что мне интересно