Dim myClass As ClassInboxMail
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Set myClass = New ClassInboxMail
End Sub

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

'Функция преобразования 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

Private Sub Application_Startup()
    Dim PauseTime As Integer, StartTime As Single
    PauseTime = 30
    StartTime = Timer
    'Устанавливаем задержку исполнения дальнейшего кода на 30 секунд
    Do While Timer < StartTime + PauseTime
        DoEvents
    Loop
End Sub

On Error Goto MyLabel
    MsgBox "Поступило новое письмо" & Chr(13) & Chr(13) & Left(ListData, Len(ListData) - 1), vbInformation + vbOKOnly, "Перечень данных всех обработанных писем"
On Error Goto 0    

On Error Resume Next
    MsgBox "Поступило новое письмо" & Chr(13) & Chr(13) & Left(ListData, Len(ListData) - 1), vbInformation + vbOKOnly, "Перечень данных всех обработанных писем"
    If Err.Number = 5 Then
        Err.Clear
        MsgBox "Проблема обработки первого сообщения после загрузки приложения Outlook!" & Chr(13) & "Повторяем после нажатия Ок", vbExclamation + vbOKOnly, "ОШИБКА"
        GoTo 1:
    End If