' этот исполняемый код

Sub СохранитьВложения()

On Error Resume Next

Dim income(1000) As String

Dim FolderName As String

Dim Myf(50) As String

Dim data As Date

Dim MonNum As String

msg = 1

Set myOlApp = CreateObject("Outlook.Application")

Set myNameSpace = myOlApp.GetNamespace("MAPI")

' Тут идет проверка количества оцениваемых сообщений (бежать по всем входящим нет смысла, долго)

Max = myNameSpace.GetDefaultFolder(olFolderInbox).Items.Count + 1

' в частности здесь берется 10 последних сообщений

MesBuffer = 10

If Max < MesBuffer Then MesBuffer = Max - 1

'проверяем больше ли чем 0 сообщений

If Max > 0 Then

' цикл по этим сообщениям

For msg = Max - MesBuffer To Max

' считаем количство вложений

atcount = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments.Count

' смотрим тему

subj = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Subject

' вот тут нужно установить бесплатную прогу, которая убирает уведомления на чтение адресов

' расположена http://www.mapilab.com/ru/outlook/security прога бесплатна и для коммерческого и для некоммерческого использования

' смотрим ИФО отправителя

SendName = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderName

' адрес отправителя

Send = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).SenderEmailAddress

' Если сообщение имеет статус непрочтеное и вложений не равно 0

If myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = True And atcount <> 0 Then

' цикл по всем вложениям

For I = 1 To atcount

' наименование вложения

income(msg) = myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1)

' тут можно сделать проверку наименования вложения

' проверка

' задаем место хранения (можно в зависимости от наименования вложения назначить путь по условию

pathOL = "E:\New\"

' Наименование файла вложения Адрес + Тема + НомерСообщения + НомерВложения + НаименованиеВложения (номер сообщения от конца)

MessageName = Send & subj & (Max - msg) & I & income(msg)

' проверяем файл на существование, если он существует в цикле создаем новую версию и ещё раз проверяем

N = 0

Do While Dir(pathOL & MessageName) <> ""

N = N + 1

MessageName = N & Send & subj & (Max - msg) & I & income(msg)

Loop

' сохраняем вложение

myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).Attachments(1).SaveAsFile pathOL & MessageName

'End If

Next I

' конец файлов непрочитанных со вложениями

End If

' помечаем сообщение как прочитанное (любое)

myNameSpace.GetDefaultFolder(olFolderInbox).Items(msg).UnRead = False

'следующее вложение

Next msg

' очищаем память

Erase income

' завершаем проверку на количество сообщений больше 0

End If

End Sub