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

MyTetra Share

Делитесь знаниями!

Ссылка на оригинал

Время создания: 16.03.2019 23:43

Текстовые метки: vba_outlook, вложения почты, attach

Раздел: Разные закладки - VBA - Outlook

Запись: xintrea/mytetra_db_adgaver_new/master/base/152300247218nuh8kq6e/text.html на raw.githubusercontent.com

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

Для автоматического копирования вложений из приходящих в 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

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

openMsg.Close olDiscard

Kill saveFolderFull & "\" & dateOfMailItem & j & objAtt.FileName 'Удаляем файл msg-файла

End If

Set objAtt = Nothing

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)

Так же в этом разделе:

MyTetra Share v.0.65