VBA to send email

Asked

Viewed 1,319 times

0

I have a VBA code to send a range as image, by outlook. But he doesn’t always glue the image to the email body, but to some part of the spreadsheet. Is something wrong with the code? thank you 

Sub EnviarEmail()
   Dim outApp As Object
   Dim outMail As Object
   Set outApp = CreateObject("Outlook.Application")
   Set outMail = outApp.CreateItem(0)
   Sheets("Tarifário - UP").Select
   ActiveSheet.Range("K8:N27").Select
   Application.CutCopyMode = False
   Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   With outMail
     .SentOnBehalfOfName = ""
     .To = ""
     .Subject = "Dados atualizados - " & Range("G2").Value & " RTG " & Range("G3").Value & " NA " & Range("G4").Value & "."
     .Body = Range("B1").Value
     .display
     SendKeys "{END}", True
     SendKeys "{Down}", True
     SendKeys "{Down}", True
     SendKeys "{Down}", True
     SendKeys "{END}", True
     SendKeys "{ENTER}", True
     SendKeys "^v", True
     SendKeys "{Down}", True
     SendKeys "{ENTER}", True
  End With
End Sub
excel vba emailing excel-vba

1 answer

0

Example where you can choose the mode as 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

Browser other questions tagged excel vba emailing excel-vba

You are not signed in. Login or sign up in order to post.