VBA to send email

Example where you can choose the way HTML or image:

Code

Sub Envia_Email()
    Dim modo As String
    'Escolhe modo ou "html" ou "imagem"
    'modo = "html"
    modo = "imagem"

    Application.DisplayAlerts = False            'desabilite o alerta

    Dim email_envio As String, email_copia As String
    Dim Contatos As Worksheet, Conteudo As Worksheet

    Set Contatos = ThisWorkbook.Worksheets("Planilha2")
    Set Conteudo = ThisWorkbook.Worksheets("Planilha3")

    email_envio = Contatos.Range("A1")           'e-mail para qual será enviado
    email_copia = Contatos.Range("A2")
    descricao = Conteudo.Name

    'https://stackoverflow.com/a/48496434/7690982
    Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
    'Intervalo da tabela que vai anexada
    Set rng = Conteudo.Range("D5:K13")
    'Debug.Print rng.Address 'Verifica o endereço

    'Verifica o modo
    If modo = "html" Then
        HtmlContent = RangetoHTML(rng)
    ElseIf modo = "imagem" Then
        rng.CopyPicture xlScreen, xlPicture
        Set temp = Sheets.Add
        temp.Shapes.AddChart
        temp.Shapes.Item(1).Select
        Set objChart = ActiveChart
        With objChart
            .ChartArea.Height = rng.Height
            .ChartArea.Width = rng.Width
            .ChartArea.Fill.Visible = msoFalse
            .ChartArea.Border.LineStyle = xlLineStyleNone
            .Paste
            imagem_temp = "temp"
            .Export Filename:=imagem_temp, FilterName:="JPG"
        End With
        temp.Delete
        HtmlContent = "<br><img src=" & "'" & imagem_temp & "'/><br>"
    Else
        MsgBox "Modo inválido"
    End If

    'https://stackoverflow.com/a/15161351/7690982
    Dim OApp As Object, OMail As Object
    Set OApp = CreateObject("Outlook.Application")
    Set OMail = OApp.CreateItem(0)
    With OMail
        .Display
    End With
    Signature = OMail.HTMLbody
    With OMail
        Introducao = "Prezado, bom dia!.<br>Segue a tabela:" 'Texto Intro Corpo do e-mail
        .To = email_envio
        .Cc = email_copia                        'Quem será copiado
        .Subject = "Assunto " & descricao        'Assunto do e-mail
        '.Attachments.Add 'Adiciona anexos
        .HTMLbody = Introducao & vbNewLine & HtmlContent & vbNewLine & Signature
        .Send
    End With
    Set OMail = Nothing
    Set OApp = Nothing

    If modo = "imagem" Then Kill imagem_temp

    Application.DisplayAlerts = True             'habilite o alerta

End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function