Sub Send_Mail_FIL()

    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
           
    sTo = "nnn@mmm.com"
    a = Format(Now + 1, "dd.mm.yyyy")
    sSubject = "Отгрузка" & a
    sBody = "<style type='text/css'>.def {font:11pt 'Calibri';color:#003366} .rb {font:bold;color:#003366}</style>"
    sBody = sBody & "<div class='def'>"
    sBody = sBody & "текст письма"
    sBody = sBody & "<br>"
    sBody = sBody & "Best regards,<br>"
    sBody = sBody & "<span class='rb'>Konstantin Korolev</span><br>"
    
    With objMail
        .To = sTo
        .CC = "nnn@mmm.com"
        .BCC = ""
        .Subject = sSubject
        .HTMLBody = sBody
        .Display
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True

Sub test()

Dim mail 'object/mail item iterator
Dim replyall 'object which will represent the reply email

For Each mail In Outlook.Application.ActiveExplorer.Selection
    If mail.Class = olMail Then
        Set replyall = mail.replyall
        With replyall
            '.Body = "blah blah hello world"  '<-- uncomment and it will delete the thread
            .Display
        End With
    End If
Next

End Sub

Sub Work_with_Outlook()
Dim SubjectOu As String

SubjectOu = InputBox("Введите тему", "Ввод")

Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String


Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & SubjectOu & "%'"

Set filteredItems = objFolder.Items.Restrict(strFilter)

If filteredItems.Count = 0 Then
    MsgBox "Нет такого"
    Found = False
Else
    Found = True
    ' this loop is optional, it displays the list of emails by subject.
    For Each itm In filteredItems
      Set ReplyAll = itm.ReplyAll
        With ReplyAll
            '.Body = "blah blah hello world"  '<--расскоментировать и вставить заготовку тескта-ответа
            .Display
        End With
     
    Next
End If


'If the subject isn't found:
If Not Found Then
    'NoResults.Show
Else
   Debug.Print "Found " & filteredItems.Count & " items."

End If

'myOlApp.Quit
Set myOlApp = Nothing


End Sub