[Solved] Paste Range into Email Body Using VBA -- copy selected (protected - column headers) rows/cells into body of the email as image

[Krp]

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.

Kun

The code I tried is here.

Method 1: Paste Range as Image into Email Body Using VBA in Excel​

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)
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 xublishsource=", _
"align=left xublishsource=")
WB.Close savechanges:=False
Kill File
Set txtstr = Nothing
Set obj = Nothing
Set WB = Nothing
End Function

 

[Yousuf Shovon]

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.

Hello Krp,

Welcome to ExcelDemy forum. I understand you wish to copy a range from a protected worksheet with a locked header row and paste it to an email body as an HTML table. Fortunately, I was able to modify the code you provided and fix it.

The algorithm: Temporarily unprotect the sheet using Unprotect method > allowing the code to copy the range using rng.Copy method> pasting it in outlook body as HTML table with RangetoHTML > reprotecting the original worksheet after email is sent using Protect method.

Use this VBA code:

Sub Paste_Range_Outlook()
    Dim rng As Range
    Dim Outlook As Object
    Dim OutlookMail As Object
    Dim tempSheet As Worksheet
  
    On Error Resume Next
    Set rng = Application.InputBox("Select the range you want to copy", Type:=8)
    On Error GoTo 0
  
    If rng Is Nothing Then
        MsgBox "No range selected or operation canceled.", vbOKOnly
        Exit Sub
    End If
  
    Dim ws As Worksheet
    Set ws = rng.Worksheet
  
    If ws.ProtectContents Then
        ws.Unprotect
    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
  
    If ws.ProtectContents Then
        ws.Protect
    End If
  
    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:=xlPasteValues
        .Cells(1).PasteSpecial xlPasteFormats
        .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

Steps:

• Select Module2.Paste_Range_Outlook >> Run.

• Enter your range and password (If worksheet is password-protected)

• Thus, we obtain the HTML table in the outlook body.

Hopefully, this works for you too. Let me know if you have further inquiries. I have attached the Excel workbook here.

Regards,
Yousuf Shovon