VBA Code to copy and paste from Excel to Outlook new Email

[HayabusaPR]

Looking for a VBA Code that Copy from Sheet1 Range A1 to K30 and paste as an Image in the body of a new email?

 

[AC PORTA VIA]

Something like this

Sub sendMail()
 

        Dim TempFilePath As String
        Dim xOutApp As Object
        Dim xOutMail As Object
        Dim xHTMLBody As String
        Dim xRg As Range
        On Error Resume Next
        Set xRg = Range("a1:k30")
        If xRg Is Nothing Then Exit Sub
        With Application
            .Calculation = xlManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        Set xOutApp = CreateObject("outlook.application")
        Set xOutMail = xOutApp.CreateItem(olMailItem)
        Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
        TempFilePath = Environ$("temp") & "\"
        xHTMLBody = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "HALO AGAIN  :<br> " _
                & "<br>" _
                & "<img src='cid:DashboardFile.jpg'>" _
                & "<br>  Thanks!</font></span>"
                Worksheets("IN PROCESS").Protect
        With xOutMail
            .Subject = "Halo"
            .HTMLBody = xHTMLBody
          .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
        
            .To = "email@1.com"
            .Cc = "email@2.com"
            .Display
        End With
        
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

 

[HayabusaPR]

works perfect, thank you so much !!!

 

[AC PORTA VIA]

You are welcome
Glad to help

 

[HayabusaPR]

Hi AC, for some reason the when the macro is pasting the table in the email is cutting half of the image

 

[AC PORTA VIA]

Hi AC, for some reason the when the macro is pasting the table in the email is cutting half of the image

not sure why
it should make an image FROM RANGE A1;K30

 

[HayabusaPR]

not sure why
it should make an image FROM RANGE A1;K30

Hi AC, for some reason was the outlook acting weird, I closed outlook, opened back and the macro with the image works.

Thanks Again!!!

 

[AC PORTA VIA]

Thanks for the feedback