Consulting

Results 1 to 7 of 7

Thread: Copy EXCEL Range to E-mail BODY

  1. #1

    Copy EXCEL Range to E-mail BODY

    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 =]
    I use Excel / Outlook 2007.

  2. #2
    VBAX Expert
    Joined
    Aug 2004
    Posts
    810
    Location
    See if this is what you are looking for:
    http://www.rondebruin.nl/sendmail.htm

  3. #3
    Quote Originally Posted by JKwan
    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?
    Last edited by NYCAnalyst; 10-10-2008 at 08:36 AM.
    I use Excel / Outlook 2007.

  4. #4
    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.

    [VBA]
    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
    [/VBA]
    I use Excel / Outlook 2007.

  5. #5

    I hope this helps

    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

  6. #6
    VBAX Newbie
    Joined
    Nov 2017
    Posts
    1
    Location
    God Bless you , gloring! You saved me so much time. Even the post is almost 10 years old....

  7. #7
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •