Copy Selected (Protected - Column Headers) Rows/Cells Into Body Of The Email As Image (1 Viewer)

[Andy Teal]

I am a new learner/novice on VBA.
The following VBA code from this forum works great to copy unprotected rows/cells to paste as image into body of the email. Thank you.
I want copy and paste selected multiples rows (cells) into body of the email as shown below.
e.g. from practice work book, i want copy a row with column header, name, age, gender, DOB, state and rows of Adam, Ted, Bill.
The row of the column header is protected so user can not edit/amend it.
Thank you in advance.

The code I tried is here:

Sub Paste_Range_Outlook()
    Dim rng As Range
    Dim Outlook As Object
    Dim OutlookMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Not a range or protected sheet" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set Outlook = CreateObject("Outlook.Application")
    Set OutlookMail = Outlook.CreateItem(0)

    On Error Resume Next
    With OutlookMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Excel Data you requested for"
        .HTMLBody = RangetoHTML(rng)
        .Display   'or use .Send
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutlookMail = Nothing
    Set Outlook = Nothing
End Sub

Function RangetoHTML(rng As Range) As String
    Dim obj As Object
    Dim txtstr As Object
    Dim File As String
    Dim WB As Workbook

    File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy

    Set WB = Workbooks.Add(1)
    With WB.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 WB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         FileName:=File, _
         Sheet:=WB.Sheets(1).Name, _
         Source:=WB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set obj = CreateObject("Scripting.FileSystemObject")
    Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
    RangetoHTML = txtstr.readall
    txtstr.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    WB.Close savechanges:=False
    Kill File
    Set txtstr = Nothing
    Set obj = Nothing
    Set WB = Nothing
End Function

 

[Gasman]

Please use code tags when you post any code. Use the </> icon.
Not doing so, removes all indentation and makes it harder to read.

With that lot I am not even going to try without indentation.

 

[Andy Teal]

Please use code tags when you post any code. Use the </> icon.
Not doing so, removes all indentation and makes it harder to read.

With that lot I am not even going to try without indentation.

@Gasman
I edited the post trying to add the code tags. Is this what you actually meant? Thank you.

 

[Gasman]

@Gasman
I edited the post trying to add the code tags. Is this what you actually meant? Thank you.

Yes, that is much better. Thank you.