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:
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:
Code:
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
Attachments
Last edited: