Как сохранить письмо на компьютер в Outlook

0
29
Microsoft Outlook

Как-то дали задачу вести архив всей входящей почты от определенных отправителей, включая вложенные в письмо файлы. Итак, как сохранить письмо из почты?

Выбор пал на Outlook. Если вкратце, то нужно создать скрипт и правило, которое выполняется при получении писем от этих отправителей.

1. Создаем скрипт. Для этого открываете Outlook, нажмите Alt + F11.

Outlook создание скрипта1. 1. Нажимаете правой кнопкой мыши на Module, выбираете InsertModule.

1. 2. В открывшемся окне вставляем текст скрипта:

Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment

Dim saveFolder As String

yearOfMailItem = Format(itm.ReceivedTime, «yyyy»)

dateOfMailItem = Format(itm.ReceivedTime, «dd.mm»)

timeOfMailItem = Format(itm.ReceivedTime, «hh.mm.ss»)

saveFolder1 = «Z:\ПУТЬ\» & yearOfMailItem

saveFolder = «Z:\ПУТЬ\» & yearOfMailItem & «\» & dateOfMailItem

If Dir(saveFolder1, vbDirectory) = «» Then

MkDir saveFolder1

End If

If Dir(saveFolder, vbDirectory) = «» Then

MkDir saveFolder

End If

For t = 1 To 100

s = Mid(itm.Subject, t, 1)

s = Replace(s, «:», «»)

s = Replace(s, «.», «»)

s = Replace(s, «/», «»)

s = Replace(s, «?», «»)

s = Replace(s, «[«, «»)

s = Replace(s, «]», «»)

s = Replace(s, «|», «»)

s = Replace(s, «,», «»)

s = Replace(s, «<«, «»)

s = Replace(s, «>», «»)

s = Replace(s, «;», «»)

s = Replace(s, «*», «»)

s = Replace(s, «^», «»)

s = Replace(s, «\», «»)

s = Replace(s, «$», «»)

s = Replace(s, «&», «»)

s = Replace(s, «%», «»)

s = Replace(s, «@», «»)

s = Replace(s, «‘», «»)

s = Replace(s, Chr(34), «»)

sSubject = sSubject & s

Next t

saveFolderFull = saveFolder & «\» & sSubject & «_» & timeOfMailItem

MkDir saveFolderFull

itm.SaveAs (saveFolderFull & «\» & sSubject & «.txt»), olTXT

For Each objAtt In itm.Attachments

saveFolderFull = saveFolder & «\» & sSubject & «_» & timeOfMailItem

If Dir(saveFolderFull, vbDirectory) = «» Then

MkDir saveFolderFull

End If

j = » «

For i = 1 To 1000

If Not Dir(saveFolderFull & «\» & objAtt.FileName) = «» Then

j = «_» & i & «_»

Else

Exit For

End If

Next i

objAtt.SaveAsFile saveFolderFull & «\» & objAtt.FileName

Set objAtt = Nothing

Next

End Sub

Данный скрипт создает папки, если они отсутствуют, по адресу Z:\ПУТЬ\ГОД\ДАТА\ТЕМА_ВРЕМЯ

где ДАТА в формате ДД.ММ. В папке ДАТА создается папка с темой письма и временем получения.

1. 3. После того, как вставили текст скрипта, его нужно сохранить — нажмите CTRL + S.

2. Теперь нужно создать правило, которое будет запускать этот скрипт при получении писем от нужных отправителей.

2.1. Для этого сверху нажмите на кнопку Правила и выберите Создать правило

СОздаем правило в Outlook2. 2. Нажмите на Дополнительно

СОздаем правило в Outlook2.3.  Выбираем пункт От и внизу в «Шаг 2» выбираем адрес отправителя.

СОздаем правило в Outlook2. 4. Жмем Далее и выбираем пункт Запустить скрипт

2. 5. внизу в Шаге 2 выбираете нужный скриптСОздаем правило в Outlook СОздаем правило в Outlook2. 6.  После жмете Далее и Готово.

 

После отработки правила создадутся такие папки:

ПутьВнутри папки сам текст письма в .txt формате и вложения.путь

 

Так же вот скрипт для календаря. Если приходит приглашение на встречу, то скрипт выше не отрабатывает.

Sub saveAttachtoDisk_calendar(itm As Outlook.MeetingItem)

Dim objAtt As Outlook.Attachment

Dim saveFolder As String

yearOfMailItem = Format(itm.ReceivedTime, «yyyy»)

dateOfMailItem = Format(itm.ReceivedTime, «dd.mm»)

timeOfMailItem = Format(itm.ReceivedTime, «hh.mm.ss»)

saveFolder1 = «Z:\ПУТЬ\» & yearOfMailItem

saveFolder = «Z:\ПУТЬ\» & yearOfMailItem & «\» & dateOfMailItem

If Dir(saveFolder1, vbDirectory) = «» Then

MkDir saveFolder1

End If

If Dir(saveFolder, vbDirectory) = «» Then

MkDir saveFolder

End If

For t = 1 To 100

s = Mid(itm.Subject, t, 1)

s = Replace(s, «:», «»)

s = Replace(s, «.», «»)

s = Replace(s, «/», «»)

s = Replace(s, «?», «»)

s = Replace(s, «[«, «»)

s = Replace(s, «]», «»)

s = Replace(s, «|», «»)

s = Replace(s, «,», «»)

s = Replace(s, «<«, «»)

s = Replace(s, «>», «»)

s = Replace(s, «;», «»)

s = Replace(s, «*», «»)

s = Replace(s, «^», «»)

s = Replace(s, «\», «»)

s = Replace(s, «$», «»)

s = Replace(s, «&», «»)

s = Replace(s, «%», «»)

s = Replace(s, «@», «»)

s = Replace(s, «‘», «»)

s = Replace(s, Chr(34), «»)

sSubject = sSubject & s

Next t

saveFolderFull = saveFolder & «\» & sSubject & «_» & timeOfMailItem

MkDir saveFolderFull

itm.SaveAs (saveFolderFull & «\» & sSubject & «.txt»), olTXT

End Sub