SMTP Email of Excel Sheets with charts.

[Compugeek_356]

I am working on automating the email distribution of an excel report. The report has data as well as a pareto chart. I have looked through many (and I mean MANY) threads on similar topics but with no success.

My problem is that I either need to determine a method copying the sheet as an image and transmitting it in the body of the message using SMTP (I have not seen that this is possible) or I need to determine a way to include the chart as an image when I publish the sheet as an html file and transmit that as an SMTP email.

I have seen solutions using Outlook and Lotus Notes applications (which allow for the use of range(xxxx).CopyPicture and .Paste into the body field but this will not work as the program will run on a remote server and I can only use SMTP calls where .Paste is not an option.

I have also seen solutions which publish the sheet to an htm format and place that onto the email. This would work, other than the chart on my sheet does not get copied correctly into the htm file and as such shows up as an error when emailed.

*I do not claim the majority of this code as mine, most of this is a conglomeration of suggestions and comments from previous thread postings. I would love to give credit to the originators, but to be honest I dont even remember where it all came from.

Sub CDO_Mail()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim rng As Range

Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.server.net"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
strbody = ""

Sheets("Data").Select
Application.Run "RefreshData" ' Macro to refresh SQL Database queries within the worksheet

Set rng = Range([A1], [K35])

With iMsg
Set .Configuration = iConf
.To = "xxxx@xxxxx.com"
.CC = ""
.BCC = ""
.ReplyTo = "xxxx@xxxx.com"
.From = "xxxx@xxxxx.com"
.subject = "Daily Report"
.HTMLBody = RangetoHTML(rng)
.Send
End With
End Sub

Function RangetoHTML(rng As Range)
' 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") & ".html"

'Publish the sheet to a htm file
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveWorkbook.Sheets(1).Name, _
Source:=Range([A1], [K36]).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 xublishsource=", _
"align=left xublishsource=")

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

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


Any suggestions would be great. Thank you in advance.