Excel VBA Question: Button Click to create a new email

[InvaderZIM05]

Hello again everyone,

I am hoping to receive your help once again.
This time, I would like to have a button to create a new email via outlook.
It could be an automated one, or a manual one.

What I want to achieve is:

1. Click a button to create an email with the recipient in cell "H3"
2. Static data for Cc will be the emails of the Supervisors
3. Body of the email will be an image / screenshot of the cells with the data I want to send them.
- This image us captured using the camera app in excel.

This can be automated where if I click the button, it will automatically send, or just create a message with the data above and I manually click send

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[InvaderZIM05]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Thank you. This is the file that contains the data I wanted to email out.
A1:F34 has the screenshot in the H6 cell. I wanted to email the screenshot, but if not possible the range of A1:F34 with the TO in the D9 cell, CC email in I2 and I3, with subject line in I4

Dropbox

www.dropbox.com

 

[mumps]

Place the code below in a regular module. Assign the first macro to your button on the sheet.

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range
    Set rng = Range("B2:E33")
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Range("D9")
        .cc = Range("I2") & ";" & Range("I3")
        .Subject = Range("I4")
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    Application.ScreenUpdating = True
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

 

[InvaderZIM05]

Place the code below in a regular module. Assign the first macro to your button on the sheet.

Sub CreateEmail()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng As Range
    Set rng = Range("B2:E33")
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Range("D9")
        .cc = Range("I2") & ";" & Range("I3")
        .Subject = Range("I4")
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    Application.ScreenUpdating = True
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

It's working! Thank you.
But is there anything I can edit so the result is as if I copy and pasted the range? It's a minor visual difference, but I was hoping to get optimal visuals if I can.
When I click the button, it gives me this outcome which somewhat changed the visuals of the document, and the company logo isn't copied.

This is what I was hoping to appear in my email

 

[mumps]

Assign this macro to your button. You can actually delete the image on your sheet as the macro creates the image and puts it in the body of the email. You can also delete the "RangetoHTML" function as it is no longer needed.

Sub CreateEmail()
    Dim r As Range, co As ChartObject, picFile As String, OutApp As Object, OutMail As Object, strBody As String
    Set r = Sheets("Approval Notification").Range("B2:E33")
    r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    picFile = Environ("Temp") & "\TempExportChart.png"
    Set co = r.Parent.ChartObjects.Add(Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r.Height)
    With co
        .Activate
        .Chart.Paste
        .Chart.Export picFile
        .Delete
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    strBody = "<body> <img src=""" & picFile & """ style=""width:304px;height:228px""></body>"
    With OutMail
        .To = Range("D9")
        .CC = Range("I2") & ";" & Range("I3")
        .Subject = Range("I4")
        .HTMLBody = strBody
        .display
    End With
    Kill picFile
End Sub