Help with pasting cells in Outlook mail and then pasting grouped image charts after, in same email body

[ejronin]

I'm attempting to generate an email in Outlook with the body as a range of cells and then paste a set of grouped charts below the cells in the same email body.

Currently, the script pastes the cells just fine - that's not a problem.

When the user runs the SendMail macro, the sheet unhides a set of data cells and the charts become visible (but screen update is False so the user doesn't see it), and then the sheet selects and copies the Group.

However, it doesn't paste this in a new line under the Range in Outlook.

I've noticed if I manually copy the Group and paste as an image in OUtlook, the body of the email seems completely formatted as cells and I have to set the image setting "through" for text and appear on the top layer, otherwise the image pastes inside a cell and the entire email body looks unappealing (and not what I'm shooting for).

Can anyone assist me with what I'm missing or doing wrong please? (plus - is there a way to block editing the cell content in outlook once pasted?)

Sub SendMail()    With ThisWorkbook.Sheets("DATS")


       
        If WorksheetFunction.CountA(Sheets("DATS").Range("E32:E38")) = 0 Then
            MsgBox "Please answer all questions in the Questionnaire Section of the DATS form.", vbCritical
            Exit Sub
        Else
            MsgBox "Preparing DATS."
            Dim rng As Range
            Dim OutApp As Object
            Dim OutMail As Object


            Set rng = Nothing
            On Error Resume Next
            ' Only send the visible cells in the selection.
            .EnableEvents = False
            .ScreenUpdating = False
            Sheet1.Unprotect Password:="****"
            Rows("67:151").Select
            Selection.EntireRow.Hidden = False
            
            Set rng = Sheets("DATS").Range("B1:L65").SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        
            If rng Is Nothing Then
                MsgBox "Something went wrong." & _
                       vbNewLine & "Sometimes a bug occurs and you need to try again." & _
                       " Try sending the DATS again, please." & _
                       vbNewLine & vbNewLine & "If this *is* the second or third attempt, " & _
                       "please contact IT via the DATS Assist Icon." & _
                       vbNewLine & vbNewLine & "(NOTE: Help Requests take a screenshot " & _
                       "of your computer screen, so ensure the DATS form is maximized prior to sending a request.)", vbOKOnly
                    Rows("66:151").Select
                    Selection.EntireRow.Hidden = True
                    Sheet1.Protect Password:="****", UserInterFaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
                Exit Sub
            End If


            With Application
                .EnableEvents = False
                .ScreenUpdating = False
                ActiveSheet.Unprotect
                Rows("66:133").Select
                Selection.EntireRow.Hidden = False
                Range("B1:L66", (Array("Group 6"))).Copy
            End With
            
            'Gets the data about which DAM to send the sheet based on the switch sets in DEV MODE
            For Each Cell In Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
                If Cell.Value Like "?*@?*.?*" And _
                   LCase(Cells(Cell.Row, "R").Value) = "yes" Then
        
                    Set OutApp = CreateObject("Outlook.Application")
                    Set OutMail = OutApp.CreateItem(0)
                
                    On Error Resume Next
                    With OutMail
                        .To = Cell.Value 'send to DAM from DIV cell linked in DEV MODE area
                        .CC = OutApp.Session.CurrentUser.Address 'CC self
                        .BCC = "" 'leave empty
                        .Subject = Range("G3").Value & " DATS Week ending: " & Range("K3").Value
                        .HTMLBody = "By submitting this time sheet, I attest the information is accurate and true to the best of my knowledge and ability." & RangetoHTML(rng) & vbNewLine & vbNewLine
                        ActiveSheet.Pictures.Paste.Select
                        .Signature = True
                        .Display 'DO NOT AUTOSEND - Sender needs to review email prior to sending
                    End With
                    On Error GoTo 0
                
                    'Hides the lower half of the METRICS cells to also hide GROUP 6 with DEV MODE AREA
                    With Application
                        Rows("66:151").Select
                        Selection.EntireRow.Hidden = True
                        Columns("N:W").Select
                        Selection.EntireColumn.Hidden = True
                        Sheet1.Protect Password:="****", UserInterFaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
                        .EnableEvents = True
                        .ScreenUpdating = True
                        Range("C3").Select
                    End With
        
            Set OutMail = Nothing
            Set OutApp = Nothing
             
          End If
          Next


        'Department reminders about sending schedules and the expense report.
        End If
        If Range("T9") = 4 Then
        MsgBox "Cell Phone Expense reports are due. Send them to the manager as an individual email today." & vbNewLine & _
        "The manager will not remind you or complete one for you.", vbExclamation + vbApplicationModal, "EXPENSE REPORT REMINDER"
        
        ElseIf Range("T9") = 3 Then
        MsgBox "Audit Schedules are due. Please prepare and submit your Audit Schedule by " & Range("J35"), vbInformation + vbApplicationModal, "AUDIT SCHEDULE DUE"
        
        
    End If
    End With
    
End Sub