How to copy range from excel and put to outlook

[Tur3n]

Dear All,
currently I have working VBA code which open new email, set subject, recipients etc:

Sub Send_email()

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strBody = "<FONT SIZE = 3>DHL Express w zalaczeniu. "

With OutMail
    .Display
    .To = "xxx@aaa.com"
    .CC = "xxx@aaa.com"
    .BCC = ""
    .Subject = "Przerzuty - " & Date
    .HTMLBody = strBody & .HTMLBody
    .Display

End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

However, I wanna to copy some selection/range from excel and put in the same format but in outlook message.

 Range("A3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

How to do it ? I don't paste it as image but only as editable table from excel.

Thanks,
Adam

 

[Tur3n]

Dears,
can someone help me with above request ?

Shall I explain in more details ?

 

[Anthony47]

In case this question is still open and the question is "how do I insert parts od a spreadsheet into an email" then I should suggest using the following Function:

Function RangePublish(ByVal mySh As String, ByVal PRan As String) As Variant
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=101351
'
Dim TmpFile As String, myBDT As String, PubFile
TmpFile = Environ("Temp") & "\myBDT.htm"    'Lavora in Temp
'Crea file html:
With ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
    Filename:=TmpFile, _
    Sheet:=mySh, _
    Source:=PRan, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
End With
'
Set FSO = CreateObject("Scripting.FilesystemObject")
Set PubFile = FSO.OpenTextFile(TmpFile, 1, False)
  RangePublish = PubFile.ReadAll
PubFile.Close
'
End Function

Add it to the same module with the current Sub Send_email, then add in your Sub Send_email the following line:

    .HTMLBody = strBody & .HTMLBody
    .HTMLBody = HTMLBody & RangePublish("YourSheetName", "YouRange")   'ex: RangePublish("Sheet1", "A2:F20")   '+++ ADDED LINE
    .Display

Try...