Как из outlook скопировать почту

Как из outlook скопировать почту

Как из 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

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

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

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



Источник: opennotes.ru


Добавить комментарий