Sub Looking_for_the_ID()

Dim i As Integer ' Счетчик для цикла перебора писем
Dim sTo As String

Set myOlApp = CreateObject("Outlook.Application")   ' Присвоить [myOlApp] приложение Outlook
Set myNamespace = myOlApp.GetNamespace("MAPI")      '   Присвоить [myNamespace] модель [MAPI]
Set myRecipient = myNamespace.CreateRecipient("mail-order") ' Присвоить [myRecipient] (Получатель писем) ["mail-order"]
myRecipient.Resolve
Set mofolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)   ' Присвоить [mofolder] папку [Inbox] ящика ["mail-order"]

Dim msg As Outlook.MailItem ' Присвоить [msg] тип - объект [Outlook.MailItem]

sSID = "0000000001F98937A4C1BD4E897050339DC29D150700A652F366EFD5944EB11E2F3EB811D605004D9A94DB530000A652F366EFD5944EB11E2F3EB811D605009B073E897D0000"   ' Присвоить [sSID] Значение ID письма для последующего поиска
MsgBox sSID
    
    If mofolder.Items.Count > 0 Then    ' Проверка того что в папке [myRecipient] есть письма
    MsgBox "Папка найдена"
    End If
    
    'MsgBox mofolder.Items.Count
    i = mofolder.Items.Count            ' Присвоить переменной [i] количество писем в В папке [mofolder], Входящие mail-order
    'MsgBox i, , "Всего писем"
    
    For i = mofolder.Items.Count To 1 Step -1   ' Цикл перебора писем от последнего к первому
    'MsgBox mofolder.Items(i).EntryID
        
        If sSID = mofolder.Items(i).EntryID Then    ' Проверка соотвествия искомого ID текущему в цикле перебора писем
        'MsgBox "Письмо найдено"
        GoTo Reply  ' Переход на метку [Reply]
        End If
        
    Next i
    GoTo Finita ' Переход в конец скрипта при неудачном поиске
    
' Метка
Reply:
MsgBox "Произошел преход в пункт Отправка письма"
    'MsgBox "Переход в SendMail"

'    Модуль отправки письма НАЧАЛО
    With mofolder.Items(i).Reply 'objMail Переслать найденное письмо
        
        .To = sTo 'адрес получателя
'        '.CC = sHead 'адрес для копии
'        '.BCC = "" 'адрес для скрытой копии
'        .Subject = sSubject 'тема сообщения
'        .Body = sBody 'текст сообщения
'        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
'        '.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
'        .SentOnBehalfOfName = "order@aircool.ru"
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра (.Send)
'        '.SendUsingAccount = objOutlookApp.Session.Accounts.Item(1)
'        '.From = "order@aircool.ru"
'        '.Send
    End With
'   'Модуль отправки письма КОНЕЦ

GoTo Finita
NotFound:
MsgBox "Письмо не было найдено, Найдите самостоятельно!"

Finita:
MsgBox "Finita"
End Sub

Sub Looking_for_the_ID()

Dim i As Integer ' Счетчик
Dim sSID As String

Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("mail-order")
myRecipient.Resolve
Set mofolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)

Dim msg As Outlook.MailItem

sSID ="0000000001F98937A4C1BD4E897050339DC29D150700A652F366EFD5944EB11E2F3EB811D605004D9A94DB530000A652F366EFD5944EB11E2F3EB811D605009ACFA60A430000"
MsgBox sSID

    If mofolder.Items.Count > 0 Then
   MsgBox "Папка не пустая"
   End If
    
    i = mofolder.Items.Count
    MsgBox i, , "Всего писем"
    
    For Each msg In mofolder.Items
     
      If msg.EntryID = sSID Then
      GoTo Reply
      End If
     
      i = i - 1
       
     Next
     GoTo Finita
    
  
Reply:
MsgBox "Отправка письма"
MsgBox i

Finita:
MsgBox "Письмо не было найдено"
End Sub