Send email via VBA excel and copy and paste range of cells

I have the below code to send an email via VBA script in excel.

But I want to copy and paste a range of cells (A6:F28) into the body of the email;

HTML Code: 

Can someone please help me out

Thanks!!

hi,
first thing you need to do is to add code tags around your code according to the forum rules!
then try this and see if it helps you

Sub Button1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

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

Set rng = Nothing
'Set rng = Sheet1.UsedRange

Set rng = Sheet1.Range("a6:f28") 'or .usedrange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "test test"
.HTMLBody = RangetoHTML(rng)
.display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
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"

'Copy the range and create a new workbook to past the data in
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
With Selection.Borders(xlEdgeBottom) 'add last line at bottom
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).Range("A6:f28").Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
'set source = worksheets(strSheet).usedrange.row(worksheets(strSheet).usedrange.rows.count) or usedrange
End With
'or.Source:=TempWB.Sheets(1).usedrange.address
'Read all data from the htm file into RangetoHTML
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=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

before to be helped by someone please do the first thing I asked you!

some time ago I used this, see if it helps you too.

Sub Button2_Click()
'http://www.excelvbamacros.in/2013/01/macro-to-send-chart-in-outlook-mail-body.html
 
    Dim objOL As Object
    Dim chrtpth As String
    Dim bdy As String
    Dim startmsg As String
    Dim endmsg As String
    
    ' create a unique Name
    chrtpth = ThisWorkbook.Path & "\" & Environ("USERNAME") & VBA.Format(VBA.Now(), "DD_MM_YY_HH_MM_SS") & ".bmp"
    'Change chart name which you want to export and check yr chart name
    Sheets("Sheet1").ChartObjects("Chart 1").Chart.Export chrtpth
    
    ' add the mail content and chart to the outlook mail body
    
    bdy = "<p align='Left'><img src=""cid:" & Mid(chrtpth, InStrRev(chrtpth, "\") + 1) & """  width=300 height=200 > <br> <br>"
    startmsg = "<font size='2' color='black'> Hi Sam," & "<br> <br>" & "Please find the chart below: " & "<br> <br> </font>"
    endmsg = "<font size='2' color='black'> Many Thanks," & "<br>" & "Geff" & "<br> <br> </font>"
    
    
    ' send the email
    
    Set objOL = CreateObject("Outlook.Application")
    Set olMail = objOL.CreateItem(olMailItem)
    
    With olMail
        .To = ""
        .Subject = "Add Chart in outlook mail body"
        .Attachments.Add chrtpth
        .HTMLBody = startmsg & bdy & endmsg
        .Display
    End With
    
    ' delete the exported chart
    Kill chrtpth
    
    Set olMail = Nothing
    Set olApp = Nothing
End Sub