Sub Send_Mail()
    Dim oOutlApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sTblBody As String, sAttachment As String
    Dim rDataR As Range
    Dim IsOultOpen As Boolean
 
    Application.ScreenUpdating = False
    'Пробуем подключиться к Outlook
    On Error Resume Next
    Set oOutlApp = GetObject(, "Outlook.Application")
    If Err = 0 Then
        IsOultOpen = True
    Else
        Err.Clear
        Set oOutlApp = CreateObject("Outlook.Application")
    End If
    oOutlApp.Session.Logon
    Set objMail = oOutlApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set oOutlApp = Nothing: Set objMail = Nothing: Exit Sub
    
    With ActiveWorkbook.Sheets("Лист 1")
        sTo = .Range("B2").Value
        sSubject = .Range("B3").Value
        sBody = .Range("B4").Value
        sAttachment = .Range("").Value
        'Переносы строк и шрифт
        sBody = Replace(sBody, Chr(10), "<br />")
        sBody = Replace(sBody, vbNewLine, "<br />")
        sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"
        'Таблица
        'важно добавлять таблицу после оформления переносов строк и шрифта
        'в противном случае форматирование таблицы может "поплыть"
        Set rDataR = .Range("") 'Selection - если надо отправить только выделенные диапазона
        sTblBody = ConvertRngToHTM(rDataR)
        'подменяем метку {TABLE} в тексте письма реальной таблицей(сформированной выше)
        sBody = Replace(sBody, "{TABLE}", sTblBody)
    End With
    
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
'        .CC = "" 'адрес для копии
'        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .BodyFormat = 2  'olFormatHTML - формат HTML
'        .Body = RangeToTextTable(Selection) 'вставляем таблицу без форматирования
        .HTMLBody = sBody
        If sAttachment <> "" Then
            .Attachments.Add sAttachment
        End If
        .display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
        '.Send 'если необходимо отправить сообщение без просмотра
    End With
    
    If IsOultOpen = False Then oOutlApp.Quit
    Set oOutlApp = Nothing: Set objMail = Nothing
    DoEvents
End Sub

Function ConvertRngToHTM(rng As Range)
    Dim fso As Object, ts As Object
    Dim sF As String, resHTM As String
    Dim wbTmp As Workbook
 
    sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'переносим указанный диапазон в новую книгу
    rng.Copy
    Set wbTmp = Workbooks.Add(1)
    With wbTmp.Sheets(1)
        'вставляем только ширину столбцов, значения и форматы
        .Cells(1).PasteSpecial xlPasteColumnWidths
        .Cells(1).PasteSpecial xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        'удаляем все объекты(фигуры, рисунки и пр.)
        '------------------------------------------
        'если рисунки и объекты нужны - удалить этот блок
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        '------------------------------------------
    End With
    'выставляем русскую кодировку (если кириллицы в тексте нет - можно убрать)
    wbTmp.WebOptions.Encoding = msoEncodingCyrillic
    'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
    With wbTmp.PublishObjects.Add( _
         SourceType:=xlSourceRange, Filename:=sF, _
         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address(1, 1, Application.ReferenceStyle), _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'открываем созданный файл как текстовый и считываем содержимое
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
    resHTM = ts.ReadAll
    ts.Close
    'выравниваем таблицу по левому краю(если надо оставить по центру - удалить эту строку)
    ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
    'закрываем временную книгу и удаляем
    wbTmp.Close False
    Kill sF
    'очищаем объектные переменные
    Set ts = Nothing: Set fso = Nothing
    Set wbTmp = Nothing
End Function
Function RangeToTextTable(rng As Range)
    Dim lr As Long, lc As Long, arr
    Dim res As String, rh()
    Dim lSpaces As Long, s As String
     
    arr = rng.Value
    If Not IsArray(arr) Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rng.Value
    End If
    ReDim rh(1 To UBound(arr, 2))
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            If Len(arr(lr, lc)) > rh(lc) Then
                rh(lc) = Len(arr(lr, lc))
            End If
        Next
    Next
    For lr = 1 To UBound(arr, 1)
        For lc = 1 To UBound(arr, 2)
            s = arr(lr, lc)
            lSpaces = rh(lc) - Len(s)
            If lSpaces > 0 Then
                s = s & Space(lSpaces)
            End If
            If lc = 1 Then
                res = res & s
            Else
                res = res & vbTab & s
            End If
        Next
        res = res & vbNewLine
    Next
    RangeToTextTable = res
End Function