Excel vba - colar print e-mail

[RAIMUNDO LIMA DE ARAUJO]

Boa tarde meus amigos(as). 

 

Se possível, poderia ajustar esse codigo para colar o intervalos da planilha que está na aba (ORDEM CARREGAMENTO), automaticamente no oultook? 

Ele até cria uma copia, porém, tenho que usar o CTRL+V para colar, veja o print abaixo. 

intervalo B1 A Q52

 

CODIGO: 

Sub Enviar_ORDEM()

Dim WH      As Worksheet
Dim OutProg As Object
Dim OutMail As Object
Dim OutApp  As Object

Set WH = Planilha8 ' PRINT QUE VAI NO E-MAIL PARA COLAR
Set OutProg = CreateObject("Outlook.Application")
Set OutMail = OutProg.CreateItem(0)

Application.ScreenUpdating = False

WH.Select

Application.ScreenUpdating = True

Application.DisplayAlerts = False

Set WH = Planilha5 ' ONDE PEGA OS E-MAIL PARA ENVIAR

Dim Anexo   As String

'Anexo = ThisWorkbook.Path ' NOME DO ARQUIVO PARA ANEXAR
'Anexo = Anexo & "\" & "ORDEM DE CARREGAMENTO.xlsm"

Anexo = MaisRecentArq(ThisWorkbook.Path & "\")
    
With OutMail
    .Display
    .To = WH.Range("D10").Value 'Para
    .CC = WH.Range("D11").Value 'Copia
    .Subject = WH.Range("D13").Value ' Assunto
    .bcc = "[email protected]"
    .Attachments.Add Anexo
    .Body = WH.Range("D15").Value ' Corpo e-mail
    '.Send
    
End With

Application.DisplayAlerts = True

Set OutMail = Nothing
Set OutApp = Nothing
Set OutProg = Nothing

Set WH = Planilha8



'o codigo abaixo, seleciona a ultima linha preenchida e dá print para ser enviado e-mail
WH.Range("B4:Q" & Cells(Rows.Count, "Q").End(xlUp).Row).Select ' usamos a coluna E para localizar a ultima linha preenchida
   
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    WH.Range("Q2").Select

    ' Salva pasta de trabalho
    
End Sub


Function MaisRecentArq(caminho As String)
Dim recenArq As String
Dim recenDt As Date
Dim nomeArq As String

nomeArq = VBA.Dir(caminho & "*.*")

If nomeArq <> "" Then
    recenArq = nomeArq
    recenDt = VBA.FileDateTime(caminho & nomeArq)
    Do While nomeArq <> ""
    With ActiveSheet
       If nomeArq Like "OR " & .[C11] & " - " & .[L11] & " - " & .[L14] & ".pdf" Then
        If VBA.FileDateTime(caminho & nomeArq) > recenDt Then
             recenArq = nomeArq
             recenDt = VBA.FileDateTime(caminho & nomeArq)
         End If
        End If
      End With
        nomeArq = VBA.Dir
    Loop
End If

MaisRecentArq = caminho & recenArq

End Function

 

 

Eu achei esse codigo aqui, que faz o que preciso, porém, não sei como adaptar no meu para colar automaticamente a imagem. 

 

Sub AdicionarImagemCorpoOutlook()
Dim outlookApp As Object
Dim outlookMessage As Object

Set outlookApp = CreateObject("outlook.application")
Set outlookMessage = outlookApp.createItem(olMailItem)

    With outlookMessage
        .htmlbody = "Aqui é o local onde será escrito o email"
        ExportarGrafico
        .Attachments.Add Environ$("temp") & "\" & "meuGrafico.jpg", olByValue, 0
        
        .htmlbody = .htmlbody & "<br><B>Relatório Semanal:</B><br>" _
            & "<img src='cid:meuGrafico.jpg'" & "><br>" _
            & "<br>Atenciosamente,<br>Cristian Firmino</font></span>"
        
        .To = "[email protected]"
        .display
        
    End With
End Sub


Sub ExportarGrafico()
    Dim nomeArquivo As String
    Dim chartGrafico As Chart
    Set chartGrafico = Sheets("teste").ChartObjects("linha").Chart

    nomeArquivo = "meuGrafico.jpg"
    chartGrafico.Export Filename:=Environ$("temp") & "\" & nomeArquivo, Filtername:="jpg"

End Sub