MyTetra Share
Делитесь знаниями!
Автоматическое копирование вложений из писем в папку
16.03.2019
23:43
Текстовые метки: VBA Outlook, Вложениея писем
Раздел: !Закладки - VBA - Outlook

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


Для автоматического копирования вложений из приходящих в 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)
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования