Sub Кнопка()


    Dim objOutlookApp As Object, objMail As Object


 


    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


    On Error GoTo 0


    'создаем сообщение


Dim arr, mailboxes As String


    arr = Range("P2:P3").Value


        For i = 1 To UBound(arr)


        If Len(mailboxes) = 0 Then


            mailboxes = arr(i, 1)


        Else


            mailboxes = mailboxes & "; " & arr(i, 1)


        End If


    Next i


     


    With objMail


        .To = mailboxes


        .cc = Range("P4").Value


        .Subject = Range("O2") & Range("O3") & Range("O4")


        .BodyFormat = 2  'olFormatHTML - формат HTML


        .HTMLBody = "<br>" & Range("A2") & ConvertRngToHTM(Range("A7 : H50")) & "<br>" & Range("A3") & "<br>" & "<b> <i>  Александр </i> </b> " & "<br>" & Range("A4") & "<br>" & Range("A5") & "<br>" & strbody & " <br> <img src='https://latifundist.com/media/company/300-s/00/01/1283/atb-104058.jpg'" & "width=150 height=150>"


        .Display 'отображаем сообщение


        .ReadReceiptRequested = False 'уведомление о прочтении


        objMail.Importance = 2 'olImportanceHigh высокая важность письма


                


    End With


 


    Set objOutlookApp = Nothing: Set objMail = Nothing


    Application.ScreenUpdating = True


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


    'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)


    With wbTmp.PublishObjects.Add( _


         SourceType:=xlSourceRange, Filename:=sF, _


         Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _


         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

Sub ТО_ПК_Кнопка()
    Dim objOutlookApp As Object, objMail As Object
 
    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
    On Error GoTo 0
    &#39;создаем сообщение
    With objMail
        .To = Range("A12").Value
        .Subject = "Текст"
        .BodyFormat = 2  &#39;olFormatHTML - формат HTML
        .HTMLBody = ConvertRngToHTM(Range("A2:M6"))
        .Display &#39;отображаем сообщение
        .ReadReceiptRequested = True
        objMail.Importance = 2 &#39;olImportanceHigh
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating= True
End Sub