Excel excel vba email html

[Kelvim]

Boa tarde

 

Eu estou utilizando um código que envia email pelo Excel usando o Outlook.

porém este código em questão eu não consigo enviar a imagem que estiver no corpo da planilha.

 

Gostaria de saber se alguem conseguiria me ajudar.

 

Sub ENVIAR_HTML()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim resultado As VbMsgBoxResult

Set rng = Nothing

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Application.DisplayAlerts = False
resultado = MsgBox("Tem certeza que deseja Enviar o Arquivo?", vbYesNo, "ENVIAR ARQUIVO")

If resultado = vbYes Then
ArqAberto01 = ActiveWorkbook.Name
Application.DisplayAlerts = False
Windows(ArqAberto01).Activate
Application.Dialogs(xlDialogOpen).Show
ArqAberto02 = ActiveWorkbook.Name
    
    Windows(ArqAberto02).Activate
    CAMINHO = Workbooks(ArqAberto02).Path
    ArqAberto02 = ActiveWorkbook.Name
    Windows(ArqAberto02).Close
    Windows(ArqAberto01).Activate
    Sheets("MENU").Select
    

Set rng = Sheets("MENSAGEM").Range("A1:L22").SpecialCells(xlCellTypeVisible)
        On Error Resume Next
        With OutMail
            .To = Sheets("CAMINHO").Range("B4").Value
            .CC = Sheets("CAMINHO").Range("B5").Value
            .BCC = ""
            .Subject = "OS - VISTORIA"
            '.HTMLBody = msg1 & RangetoHTML(rng)
            .HTMLBody = RangetoHTML(rng) '& Assinatura
        Set Signature = Account.NewMessageSignature
            .Attachments.Add ("" & CAMINHO & "\" & ArqAberto02 & "")
            .display
        End With
        SendKeys "^{ENTER}"
        On Error GoTo 0
        Set OutMail = Nothing
        Set OutApp = Nothing

Else
End If
End Sub

 

Function RangetoHTML(rng As Range)
    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"
    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
    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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

[Basole]

A imagem está em que planilha (aba) e em que célula ? 

[Kelvim]

esta por exemplo na aba MENSAG - PRESENCIAL celula A44

porém na mesma aba MENSAG - PRESENCIAL existe alguns gráficos

que também gostaria de enviar

[Kelvim]

@Basole Segue acima

[Barbossa]

Boa noite,

 

Sei que o tópico já é antigo, mas não custa perguntar.

 

Eu estou tentando fazer está mesma configuração em uma planilha do Excel. Utilizo está mesma função do amigo a cima, e com ela monto uma tabela com algumas informações e abaixo dela, coloco alguns prints que gostaria de enviar junto no e-mail, mas não consigo fazer ele puxar a imagem junto.

 

Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)

 

Não entendo muito de vba, mas me parece ser o código dessa linha que faz puxar como texto,mas não sei ao certo pelo que trocar para funcionar.

Sera que alguém sabe o que fazer? Ou se tem algum tópico aqui que tenha a solução?

 

 

[Wendell Menezes]

Pode postar sua planilha e um print de como gostaria que o e-mail ficasse?

[Barbossa]

Você precisa do arquivo da planilha ou de um print dela?

[Barbossa]

@Wendell Menezes Seria mais ou menos isso aí que estou tentando montar. Coloquei um print dentro dela de como ela ficaria no e-mail.

As imagens que vão junto da tabela, são prints que tenho que mandar de evidências. Podendo variar na quantidade de prints e de linhas da tabela que preciso enviar.TESTE.xlsm.xlsx

Resumindo, são análises que faço de alguns produtos e envio um e-mail com o status de quantos dias esses produtos expira.

 

TESTE.xlsm.xlsx

[Wendell Menezes]

@Dammond , segue versão do arquivo que inclui o print.

 

Altere essa linha para controlar o tamanho da imagem:

 

Set cht = ActiveSheet.ChartObjects.Add(Left:=10, Width:=750, Top:=10, Height:=250)

 

Essa parte define quais objetos NÃO devem fazer parte da imagem:

 

For Each Shape In ActiveSheet.Shapes
    If Shape.Name <> "Rolagem Horizontal 1" And Shape.Name <> "Retângulo Arredondado 4" And Shape.Name <> "exemplo" And Shape.Name <> "Temp Chart" Then
        Shape.Select False
    End If
Next

 

Copy of TESTE.zip

[Barbossa]

@Wendell Menezes muito obrigado pela ajuda cara, ajudou muito