email spreadsheet including 2 chart

I use the following code to email a range in an excel spreadsheet. The charts do not appear in the mail although theyare included in the range. I have attached an image as an example. (the charts are not updated in the image)

What do I have to add to the code?

Thanks,
CC
Sub PositionMail()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    Set rng = Sheets("Position").Range("a1:Q36").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

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

    On Error Resume Next
    With OutMail
        .To = "xx@xx.com"
        .CC = ""
        .BCC = ""
        .Subject = "xx PosititonSheet" & " " & Date
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    'ActiveWorkbook.Close True
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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
        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).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
        
    End With
 
    '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

Open in new window

Example-of-spreadsheet-as-email.bmp
CC10Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

dlmilleCommented:
The code you are using will not email images in the Excel Range by embedding them in Outlook.  It uses PasteSpecial value and the conversion to HTML precludes the image.  Do you want the entire range of Excel to be a picture, and that picture embedded in Outlook?  Or, do you want it to work as is, with any images sequentially Embedded at the bottom of the Outlook Email?

PS - not sure it matters, but what version of Office are you using?

I would use the article here, with appropraite code: http://www.jpsoftwaretech.com/excel-vba/send-email-from-excel/

Give me a few and I'll update your code with this.

Dave
0
dlmilleCommented:
This version makes a picture out of the entire range and embeds it in your email.  Note in RangeToHTML2 there's a place for you to add text below the paste if needed, otherwise you'll want to blank that out.

-------------------
Here's your modified code (not I created a RangeToHTML2 routine using the tip I posted above):

Option Explicit
Public Const TEMP_PIC_NAME = "EmailTemp.png" 'change extension to change picture type
Sub PositionMail()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    Set rng = Sheets("Position").Range("A1:Q36").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

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

    'On Error Resume Next
    With OutMail
        .To = "xx@xx.com"
        .CC = ""
        .BCC = ""
        .Subject = "xx PosititonSheet" & " " & Date
        .HTMLBody = RangetoHTML2(rng)
        .display 'Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    'ActiveWorkbook.Close True
End Sub
'Following CopyRangeToGIF and RangetoHTML2 routines Source:  Adapted from: http://www.jpsoftwaretech.com/excel-vba/send-email-from-excel/
Sub CopyRangeToGIF(rng As Range) ' save a range from Excel as a picture
'Dim rng As Excel.Range
Dim cht As Excel.ChartObject
Dim imgSrc As String

    imgSrc = ThisWorkbook.Path & "\" & TEMP_PIC_NAME
    Application.ScreenUpdating = False
    'Set rng = Range("A1").CurrentRegion
    rng.CopyPicture xlScreen, xlPicture
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    cht.Chart.Paste
    cht.Chart.Export imgSrc
    cht.Delete
ExitProc:
    Application.ScreenUpdating = True
    Set cht = Nothing
    Set rng = Nothing

End Sub
Function RangetoHTML2(rng As Range)
Dim imgSrc As String

    Call CopyRangeToGIF(rng)
    imgSrc = ThisWorkbook.Path & "\" & TEMP_PIC_NAME
    RangetoHTML2 = "<body><font face=Arial color=#000080 size=2></font>" & _
        "<img alt='' hspace=0 src='" & imgSrc & "' align=baseline 0rder=0>&nbsp;" & _
        "<br /><br />Plus add any text you want</body>"
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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
        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).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
        
    End With
 
    '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

Open in new window


See attached demonstration workbook.

Dave
chtRngToEmail-r1.xls
0
CC10Author Commented:
Dave, thanks for your help. Your version works although it does not send the mail automatically. The E-mail window pops up and I have to press send manually. Can you fix it so that it sends the mail automatically.

ALSO, if I copy the script into my workbook I get a debug message on line
rng.CopyPicture xlScreen, xlPicture

Sub CopyRangeToGIF(rng As Range) ' save a range from Excel as a picture
'Dim rng As Excel.Range
Dim cht As Excel.ChartObject
Dim imgSrc As String

    imgSrc = ThisWorkbook.Path & "\" & TEMP_PIC_NAME
    Application.ScreenUpdating = False
    'Set rng = Range("A1").CurrentRegion
    rng.CopyPicture xlScreen, xlPicture
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
    cht.Chart.Paste
    cht.Chart.Export imgSrc
    cht.Delete
ExitProc:
    Application.ScreenUpdating = True
    Set cht = Nothing
    Set rng = Nothing

End Sub
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

dlmilleCommented:
In your main code, you create an object to the Outlook application, then
Just change the Outmail .Display to .Send:

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

    'On Error Resume Next
    With OutMail
        .To = "xx@xx.com"
        .CC = ""
        .BCC = ""
        .Subject = "xx PosititonSheet" & " " & Date
        .HTMLBody = RangetoHTML2(rng)
        .Send   'or use .Display
    End With

Open in new window


Attached, this has been changed.  PLEASE ENSURE THIS CODE IS PUT IN A PUBLIC MODULE.  Like Module1.  Don't put it in the Sheet1 or ThisWorkbook code page in the VBE editor.

As far as the debug window error - what exactly is the error?  Can you try the code I've put in (I put a couple print statements that will appear in your debug window with RANGE IS: and WORKBOOK/SHEET IS: - please let me know what this says when you get the error again).

Dave
chtRngToEmail-r2.xls
0
CC10Author Commented:
I used your workbook and copied in all my worksheets to create the identical workbook that I had originally but with your code included. When I run the macro, I get this error:

RunTime error 1004
That command cannot be used on multiple selections
0
dlmilleCommented:
I get it.  Its because you have hidden rows and the use this line:

Set rng = Sheets("Position").Range("A1:Q36").SpecialCells(xlCellTypeVisible)

We should just be able to change it to:

Set rng = Sheets("Position").Range("A1:Q36")

See attached.

Dave
chtRngToEmail-r3.xls
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
CC10Author Commented:
It works perfectly. Many Thanks. It is really helpful.

Best
CC
0
CC10Author Commented:
It works perfectly. Many Thanks. It is really helpful.

Best
CC
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.