Copy EXCEL Range to E-mail BODY

[NYCAnalyst]

How do you copy an excel range (of a file already attached to the email) to the body of the e-mail:


As HTML?
As a Microsoft Office Excel Worksheet Object
As a bitmap?Thanks =]

[JKwan]

See if this is what you are looking for:
http://www.rondebruin.nl/sendmail.htm

[NYCAnalyst]

See if this is what you are looking for:
http://www.rondebruin.nl/sendmail.htm

It helps a bit. How can I paste an Excel Range (not a chart) in the email body as a bitmap?

[NYCAnalyst]

This code is the closest I've gotten:

(From here: http://www.ozgrid.com/forum/showthread.php?t=31388)

However, the code returns in the eMail body:

"This page uses frames, but your browser doesn't support them."

Does anyone know why this is happening and how to fix?

Thanks.


Sub Email_HoldOvers()
Dim SB
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sSubject, sTo As String
Dim ExcelApp As Excel.Application
Dim ExcelXls As Excel.Workbook
Application.ScreenUpdating = False

Application.DisplayAlerts = False

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

SB = ThisWorkbook.Sheets("Sheet1").Range("C2")

sTo = "" ' put the address's in here I left it blank so you can test it
sSubject = SB

Application.CutCopyMode = False
ThisWorkbook.Sheets("Sheet1").Activate
ThisWorkbook.Sheets("Sheet1").Range("A1:G16").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set ExcelApp = CreateObject("Excel.Application")
End If
On Error GoTo 0


Set ExcelXls = ExcelApp.Workbooks.Add

ExcelXls.Activate

ActiveSheet.Paste
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayZeros = False
Application.CutCopyMode = False

With OutMail
.To = sTo
.Subject = sSubject
'.BodyFormat
.HTMLBody = SheetToHTML(ActiveSheet)
.Save
.Display
End With

Set OutMail = Nothing
Set OutApp = Nothing

ExcelXls.Close
Application.ScreenUpdating = True

Application.DisplayAlerts = True
End Sub
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim fso As Object
Dim ts As Object
Dim sTemp As String

Randomize

sh.Copy
TempFile = sh.Parent.Path & "TmpHTML" & Int(Rnd() * 10) & ".htm"

ActiveWorkbook.SaveAs TempFile, xlHtml
ActiveWorkbook.Close False

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)

sTemp = ts.ReadAll

SheetToHTML = ConvertPixToWeb(sTemp, sh) 'this line is new

ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function

Public Function ConvertPixToWeb(sHTML As String, sh As Worksheet) As String

Dim Pic As Picture
Dim lGif As Long
Dim lSrcStr As Long
Dim lSrcEnd As Long
Dim sUrl As String

Dim i As Long
For Each Pic In sh.Pictures
i = i + 1
lGif = InStr(1, sHTML, Format(i, "000")) '& ".bmp")
lSrcStr = InStrRev(sHTML, Chr$(34), lGif)
lSrcEnd = lGif + Len(Format(i, "000")) '& ".bmp")
' sUrl = Chr$(34) & sh.Shapes(Pic.Name)
sHTML = Replace(sHTML, Mid(sHTML, lSrcStr, lSrcEnd - lSrcStr + 1), sUrl)
Next Pic

ConvertPixToWeb = sHTML

End Function

[gloring]

Sub Emailrange()
ActiveSheet.Range("A1:B5").Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = "This is a test."
.Item.To = ABD@xxx.com
.Item.Subject = "subject"
.Item.Send
End With
End Sub


I hopt this helps......

Thanks,
Natty

[Taya]

God Bless you , gloring! You saved me so much time. Even the post is almost 10 years old....

[gmayor]

Personally I would do it like this


Option Explicit

Sub SendWorkBook()
'Graham Mayor - http://www.gmayor.com - Last updated - 26 Nov 2017
'This macro requires the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook

Dim oOutlookApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlRng As Range
Set xlRng = Range("$I$22:$M$36") 'The range to be copied
xlRng.Copy 'Copy it

Set oOutlookApp = OutlookApp() 'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook, or it will not work correctly

'Create a new mailitem
Set oItem = oOutlookApp.createitem(0)
With oItem
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
oRng.collapse 1 'set a range to the start of the message
oRng.Text = "This is the message body before the Excel range:" & vbCr & vbCr
'Collapse the range to its end
oRng.collapse 0
oRng.Text = vbCr & "This is the text after the Excel range."
'The range will be followed by the signature associated with the mail account
'collapse the range to its start
oRng.collapse 1
'paste the excel range in the message
oRng.Paste
'Address the message
.To = "someone@somewhere.com"
'Give it a title
.Subject = "This is the subject"
'attach the workbook
.attachments.Add ActiveWorkbook.FullName
'display the message - this line is required even if you then add the command to send the message
.display
End With

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set xlRng = Nothing
lbl_Exit:
Exit Sub
End Sub