Здравствуйте, уважаемые!
В Outlook2016 реализован код обработки события поступления нового сообщения.
Обработка этого события инициируется в разделе проекта ThisOutlookSession путем создания объекта класса модуля:
1.
2.
3.
4.
Dim myClass As ClassInboxMail
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Set myClass = New ClassInboxMail
End Sub
Само сообщение обрабатывается уже самим созданным пользовательским объектом в классе модуля ClassInboxMail.
Суть обработки простая: пробежаться по всем непрочитанным объектам, накопившимися в папке "Входящие", из объектов, являющимися сообщениями электронной почты, определить отправителя, тему сообщения, адрес отправителя, есть ли в сообщении вложения и, если таковые имеются, то посчитать количество и сохранить исключительно прикрепленные, но не вложенные в тело сообщения в определенной директории на дисковом пространстве и выдать информационное сообщение на экран с общим итогом в виде отчета.
При этом заложено, что в каком бы приложении в настоящее время не находился пользователь, приложению Outlook должен передаваться фокус, и окно приложения должно появляться поверх всех открытых приложений.
Вот как это реализовано кодом в классе модуля.
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
Private WithEvents myOlApp As Outlook.Application
Private Sub Class_Initialize()
Dim WShell
Set WShell = CreateObject("Wscript.Shell")
Set myOlApp = Outlook.Application
Set myOlApp.ActiveExplorer.CurrentFolder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 'назначаем текущую папку
'Активируем приложение Outlook и выводим его на передний план
WShell.AppActivate "Входящие - SMTP-адрес пользователя в Outlook - Outlook"
End Sub
Private Sub Class_Terminate()
Set myOlApp = Nothing
End Sub
Private Sub myOlApp_NewMail()
'указывает на вложение в теле сообщения (прописано в HTML коде тела сообщения)
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
'указывает на вложение в строке в теме, а не на внедренное изображение.
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myFolder As Outlook.MAPIFolder ' для папки по умолчанию
Dim myFolder_save As Outlook.MAPIFolder ' для папки куда будем перемещать полученное письмо после обработки
Dim myObj As Object ' объект письмо (из него вытягиваем тему, адрес отправителя, вложение)
Dim oAtt As Attachment 'объект вложение
Dim oPA As PropertyAccessor, cid As String 'параметры, определяющие свойства вложений и идентификатор, что вложение находится в теле письма (cid)
Dim body As String 'текст письма на HTML
Dim ListData As String, EmailAddress As String, I As Integer, ValAtt As Integer
ListData = ""
DestFolder = "путь, определяемый пользователем" ' папка, куда выкладываем вложение из письма
Set myFolder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' для работы используем папку по умолчанию "входящие" - inbox
Set myFolder_save = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Обработанные") ' для хранения обработанных писем используем папку "Обработанные", она вложена в папку входящие GetDefaultFolder(olFolderInbox)
Set myObj = myFolder.Items.Restrict("[Unread]=TRUE") 'выбор всех объектов в папке входящие, отмеченных как непрочтенные
'Проверяем существование директории, куда будем сохранять прикрепленные к письму файлы. Если ее нет, то создаём
If Dir(DestFolder, vbDirectory) = "" Then MkDir DestFolder
'Цикл перебора всех объектов в просматриваемой папки с конца
For I = myObj.Count To 1 Step -1
'Если объект является сообщением электронной почты
ValAtt = 0
If TypeOf myObj(I) Is MailItem Then
EmailAddress = fnGetSMTPAddress(myObj(I).SenderEmailAddress)
ListData = ListData & "Отправитель: " & myObj(I).SenderName & Chr(13) & "Письмо с темой: " & myObj(I).Subject & Chr(13) & "Email отправителя: " & EmailAddress & Chr(13)
If myObj(I).Attachments.Count > 0 Then ' если вложения есть, сохраняем их в цикле
body = myObj(I).HTMLBody
'Цикл обработки всех вложений в обрабатываемом сообщении
For Each oAtt In myObj(I).Attachments
'Debug.Print DestFolder & oAtt.DisplayName ' полный путь к файлу
'Определяем все свойства вложения
Set oPA = oAtt.PropertyAccessor
'Проверяем на наличие вложения в тело объекта сообщения
cid = oPA.GetProperty(PR_ATTACH_CONTENT_ID)
'Если в HTML коде найдено значение cid (данное рассматриваемое вложение находится в теле сообщения), игнорируем его
If Len(cid) > 0 Then
'Проверяем его позицию в тексте
If InStr(body, cid) Then
Else
'Если изображение не находится в основной части письма (оно находится в ветке альтернативной части), добавляем проверку, используя параметр PR_ATTACHMENT_HIDDEN
'В случае, если PR_ATTACHMENT_HIDDEN не существует, возникнет ошибка.
'Мы просто игнорируем эту ошибку и рассматриваем ее как ложную.
On Error Resume Next
If Not oPA.GetProperty(PR_ATTACHMENT_HIDDEN) Then
oAtt.SaveAsFile DestFolder & oAtt.DisplayName ' сохраняем файл на диске
ValAtt = ValAtt + 1
End If
On Error GoTo 0
End If
Else
oAtt.SaveAsFile DestFolder & oAtt.DisplayName ' сохраняем файл на диске
ValAtt = ValAtt + 1
End If
Next 'переходим к следующему вложению текущего письма
End If 'условия: myObj(I).Attachments.Count > 0
ListData = ListData & "Количество вложений: " & ValAtt & Chr(13)
End If 'условия, что обрабатываемый объект является письмом
Next ' переходим к следующему письму
Beep
MsgBox "Поступило новое письмо" & Chr(13) & Chr(13) & Left(ListData, Len(ListData) - 1), vbInformation + vbOKOnly, "Перечень данных всех обработанных писем"
Set myOlApp.ActiveExplorer.CurrentFolder = myFolder_save 'назначаем текущую папку
End Sub
При определении SMTP-адреса отправителя используем функцию, которая размещается в обычном модуле:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
'Функция преобразования email адреса отправителя к формату SMTP-адрес
Public Function fnGetSMTPAddress(ExchangeMailAddress As String) As String
Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem
Set objOutlook = New Outlook.Application
'Создаем новый объект - письмо
Set objMailItem = objOutlook.CreateItem(olMailItem)
'Определяем получателя виртуального сообщения
objMailItem.To = ExchangeMailAddress
'Проверяем существование такого получателя в базе Outlook, разрешая его добавление в список получателей Recipients
'Формируем виртуальный список получателей Recipients
objMailItem.Recipients.ResolveAll
'Если пришло внешнее письмо (адрес идентифицирован в формате SMTP-адрес)
If objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser Is Nothing Then
fnGetSMTPAddress = ExchangeMailAddress
'Идентифицируем сведения о получателе через объект AddressEntry, сведения о получателе в глобальном списке адресов Exchange через объект GetExchangeUser и
'получаем строку, представляющую основной SMTP-адрес для ExchangeUser свойством PrimarySmtpAddress
Else
fnGetSMTPAddress = objMailItem.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Set objMailItem = Nothing
Set objOutlook = Nothing
End Function
И все как бы замечательно, оттестировано, по шагам пройдено и, начиная с получения второго и последующих сообщений, за исключением некоторых нюансов, работает безукоризненно.
Проблема возникает при получении самого первого нового сообщения после загрузки приложения.
Сразу оговорюсь, макросы включены, никаких правил не установлено.
Но почему-то код на строке вывода итогового сообщения выдает ошибку (строка MsgBox).
Отладчик показывает, что параметр ListData пустой, соответственно, конечно длина сообщения отрицательная, что является ошибкой.
При этом, в режиме отладки перевожу курсор на начало исполнительного кода, заново возобновляю процесс и все отрабатывает замечательно.
Из нюансов работы кода следует отметить, что по непонятным мне причинам команда WShell.AppActivate начинает срабатывать не сразу, а живет какой-то своей жизнью.. Через какое-то время она как бы раскочегаривается и начинает отрабатывать заложенную в нее функцию.
У кого-нибудь есть идеи, соображения, от чего так происходит и как с этим бороться?
