Sub Отправить_Почту()
Dim lRetVal As Long 'для получения выбранного значения
    lRetVal = MsgBox("Проверь получателя!" & Chr(10) & ActiveCell.EntireRow.Cells(2) & " Он?" & Chr(10) & "Отправляю!", vbYesNo + vbQuestion, "ПОДУМАЙ,ПЕНЬ!!!")
    If lRetVal = vbNo Then
        Exit Sub 'выходим из процедуры без выполнения
    End If
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    
    sTo = ActiveCell    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = Range("E1").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("B1").Value   'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = Range("D6").Value    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject & "  " & Range("D4") 'тема сообщения
        .Body = sBody & Chr(10) & "  " & Chr(10) & Range("D5")  'текст сообщения
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        .Attachments.Add Range("D7").Value
        .Attachments.Add Range("D8").Value
        .Attachments.Add Range("D9").Value
        .Attachments.Add Range("D10").Value
        .Attachments.Add Range("D11").Value
        .Send 'Display - просмотреть сообщение, Send - без просмотра
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    ActiveCell.EntireRow.Cells(10) = Date ' дата в столбец 10 той же строки
    ActiveWorkbook.Save
End Sub