Sending chart in e-mail body using Excel VBA

[megaron]

Hi all,

I'm using Excel 2010, and the code below works but it's not optimal.

I'm trying to create a vba code that attaches a chart into the body of an e-mail to be viewed by e-mail (outside of network) and iphone.

Searching online, I found a way to export the chart into a Local/Network/Sharepoint drive, then HTML img source the file back into the e-mail. However, this process requires that the file remains on the disk or network drive. If the file is deleted, then no image will appear, and If it's on the network, it slowly loads, especially on sharepoint

Any suggestions? cutting and pasting would be ideal but I don't think that is supported....

Ranny

----------------------------
Code:

Sub Sendmail()

'Working in 2000-2010

Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String

'Turn on Outlook for Excel
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Path name
Fname = "X:\roni_" & Format(Date, "dd-mm-yy") & ".jpg"
' X is mapped to sharepoint site C:\Users\rkhano\AppData\Roaming\Microsoft\Windows\Network Shortcuts\Sharepoint\roni_" & Format(Date, "dd-mm-yy") & ".jpg"

'Action on worksheet
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 1").Chart.Export Filename:=Fname, FilterName:="jpg"

With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Test Chart"
.Attachments.Add Fname

'replace x with <
s = "xpxHourly US GMV Chartxpx"
s = s & "xpxximg src=file://" & Fname & "xx/px"
s = "xHTMLxxBODYx" & s & "xHTMLxxBODYx"

.HTMLBody = s
.Send 'or use .Display
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

 

[Domenic]

Try...

**Remove the spaces before and after "<" and ">"

[font=Courier New].Attachments.Add Fname
s = "< p >Hourly US GMV Chart< /p >" & vbNewLine
s = s & "< img src=""cid:roni_" & Format(Date, "dd-mm-yy") & ".jpg"" > " & vbNewLine
s = s & "< p >Bye...< /p >"
.HTMLBody = s[/font]

Note that the image file still needs to be attached to the email.

 

[megaron]

Thanks Domonic.

It worked!

Now what if I wanted to add a few charts in the e-mail. This trick works great for e-mail, but now, on the iphone, nothing is showing since the attachments are pulled into the body...

Sub test()

'Refresh all data
'ActiveWorkbook.RefreshAll

'Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim Fname2 As String

'Turn on Outlook for Excel
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'v = network drive, and this string "Fname" copies chart4 from worksheet hourly. Added -1 to date becuase the data is delayed one day
Fname = "v:/US_GMV_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 4").Chart.Export _
Filename:=Fname, FilterName:="GIF"

'v = network drive, and this string "Fname2" copies chart1 from worksheet ASP. Added -1 to date becuase the data is delayed one day
Fname2 = "v:/US_ASP_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("ASP").ChartObjects("Chart 1").Chart.Export _
Filename:=Fname2, FilterName:="GIF"

'send E-mail
With OutMail
.To = "my e-mail"
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Sheets("Hourly").Range("Y1").Value
.Attachments.Add Fname
.Attachments.Add Fname2
'chart 4 title
s = "Hourly US GMV Chart
" & vbNewLine
'source chart4 from attachment
s = s & "

" & vbNewLine
'chart 1 title
s = s & "Hourly US ASP Chart
" & vbNewLine
'source chart1 from attachment
s = s & "

" & vbNewLine
.HTMLBody = s
.Send 'or use .Display

End With
'On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

 

[megaron]

This is what I'm getting on iPhone...

Latest:

Previous:

 

[Domenic]

I can't tell what string you've assigned your "s" variable. Did you try something like this?

**Remove the spaces before and after "<" and ">"

s = "< p >Hourly US GMV Chart< /p >" & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname, InStrRev(Fname, "\") + 1) & """ > " & vbNewLine
s = s & "< p >Hourly US ASP Chart< /p >" & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname2, InStrRev(Fname2, "\") + 1) & """ > " & vbNewLine

 

[megaron]

Sorry the board removed the text.

s = s & "< img src=""cid:US_GMV_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine

s = s & "< img src=""cid:US_ASP_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine

I'll try your suggestion...

 

[megaron]

Hey Domenic,

Thanks you so much for your help, but unfortunetly it didn't work. It will show error for the src, but iphone will attach the images at the bottom....erggg...it looks sloppy for the professional world ...See pictures below

Continue..

 

[megaron]

Ran into another issue. I'm using window scheduler to open the file, refresh, save charts, send e-mail, and then quit application.

However, some of the 5 charts export at 0kb?? Not sure what I'm doing wrong...

Sub Autpen()
'Refresh all data
ActiveWorkbook.RefreshAll

'Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim Fname2 As String
Dim Fname3 As String
Dim Fname4 As String
Dim Fname5 As String

'Turn on Outlook for Excel
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'v = network drive, and this string "Fname" copies chart4 from worksheet hourly. Added -1 to date becuase the data is delayed one day
Fname = "v:\US_GMV_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 4").Chart.Export _
Filename:=Fname, FilterName:="GIF"

'Wait 5 seconds before performing the next action
Application.Wait Now + TimeValue("00:00:05")

'v = network drive, and this string "Fname2" copies chart1 from worksheet ASP. Added -1 to date becuase the data is delayed one day
Fname2 = "v:\US_SI_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 2").Chart.Export _
Filename:=Fname2, FilterName:="GIF"

'Wait 5 seconds before performing the next action
Application.Wait Now + TimeValue("00:00:05")

'v = network drive, and this string "Fname3" copies chart1 from worksheet ASP. Added -1 to date becuase the data is delayed one day
Fname3 = "v:\US_ASP_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 3").Chart.Export _
Filename:=Fname3, FilterName:="GIF"

'Wait 5 seconds before performing the next action
Application.Wait Now + TimeValue("00:00:05")

'v = network drive, and this string "Fname4" copies chart1 from worksheet ASP. Added -1 to date becuase the data is delayed one day
Fname4 = "v:\US_Domestic_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 5").Chart.Export _
Filename:=Fname4, FilterName:="GIF"

'Wait 5 seconds before performing the next action
Application.Wait Now + TimeValue("00:00:05")

'v = network drive, and this string "Fname5" copies chart1 from worksheet ASP. Added -1 to date becuase the data is delayed one day
Fname5 = "v:\US_Export_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"
ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 6").Chart.Export _
Filename:=Fname5, FilterName:="GIF"

'send E-mail
With OutMail
.To = "my e-mail"
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Sheets("Hourly").Range("BO1").Value
.Attachments.Add Fname
.Attachments.Add Fname2
.Attachments.Add Fname3
.Attachments.Add Fname4
.Attachments.Add Fname5

'chart 4 title
s = "< p >Hourly US GMV Chart< /p >" & vbNewLine
'source chart4 from attachment
's = s & "< img src=""cid:US_GMV_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname, InStrRev(Fname, "\") + 1) & """ > " & vbNewLine

'chart 2 title
s = s & "< p >Hourly US SI Chart< /p >" & vbNewLine
'source chart2 from attachment
's = s & "< img src=""cid:US_SI_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname2, InStrRev(Fname2, "\") + 1) & """ > " & vbNewLine

'chart 3 title
s = s & "< p >Hourly US ASP Chart< /p >" & vbNewLine
'source chart3 from attachment
's = s & "< img src=""cid:US_ASP_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname3, InStrRev(Fname3, "\") + 1) & """ > " & vbNewLine

'chart 5 title
s = s & "< p >Hourly US Domestic Chart< /p >" & vbNewLine
'source chart5 from attachment
's = s & "< img src=""cid:US_Domestic_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname4, InStrRev(Fname4, "\") + 1) & """ > " & vbNewLine

'chart 6 title
s = s & "< p >Hourly US Export Chart< /p >" & vbNewLine
'source chart6 from attachment
's = s & "< img src=""cid:US_Export_" & Format(Now() - 1, "mm-dd-yyyy") & ".gif"" > " & vbNewLine
s = s & "< img src=""cid:" & Mid(Fname5, InStrRev(Fname5, "\") + 1) & """ > " & vbNewLine

.HTMLBody = s
.Send 'or use .Display

End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

ActiveWorkbook.EnvelopeVisible = False

'Turn off Excel save notifcation
Application.DisplayAlerts = False

'Directory change
ChDir "C:\Users\rkhano\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\rkhano\Desktop\ChartHourly3.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'Turn on Excel save notification
Application.DisplayAlerts = True
'Quit Excel
Application.Quit

End Sub

 

[megaron]

Bump

 

[Domenic]

See if it helps if you activate the chart before exporting it. So, for example, for the first chart, replace...

[font=Courier New]ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 4").Chart.Export _
Filename:=Fname, FilterName:="GIF"

with

[color=darkblue]With[/color] ActiveWorkbook.Worksheets("Hourly").ChartObjects("Chart 4")
    .Activate
    .Chart.Export Filename:=Fname, FilterName:="GIF"
[color=darkblue]End[/color] [color=darkblue]With[/color]
[/font]