- Open Notes - http://opennotes.ru -

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

Posted By Konstantin On In VBA | 140 Comments

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

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

Код:

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). Чтобы макрос сработал:

  1. Откройте вкладку «Файл» (File), выберите настройки (Outlook Options) -> настройки безопасности (Trust Center).
  2. Нажмите на настройки центра безопасности (Trust Center Settings), затем на настройки макросов слева (Macro Settings)
  3. Выберите вариант уведомления обо всех макроса (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

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

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

Order_macros