Excel VBA - Email Charts and Photos

shophoney

Active Member
Joined
Jun 16, 2014
Messages
256
Hi,

wondering if there is VBA to email charts and data in a range that can vary. And also photos with text below.

I've tried a few things but I've had no luck.

Below is my code for email, but pictures don't get sent.

Sub CDO_MTD_BY_VENDOR()
Dim rng As Range
Dim iMsg As Object
Dim iConf As Object
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/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxx@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "ABCDEF"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Update
End With

Set rng = Nothing
On Error Resume Next

'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'Set rng = Sheets("Sheet1").Range("A1:J35").SpecialCells(xlCellTypeVisible)
' added hours colum
Set rng = Sheets("MTD").Range("F2:H99")
'Set rng = ActiveSheet.UsedRange

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

With iMsg
Set .Configuration = iConf
.To = "ABCD@yahoo.ca"
.CC = "ABCD@XXYZ.COM"
.From = """No_reply"" <No_reply@XYZ.com>"
.Subject = ActiveSheet.Range("F4").Value & " - " & Format(Now, "MMM dd/yy")
.HTMLBody = RangetoHTML(rng)
.Send
End With

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

On Error Resume Next

If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "There was an error"
Exit Sub
End If
End Sub



Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Dim i As Long
For i = rng.Rows.Count To 1 Step -1
'****CHANGE COLUMN TO REVIEW CRITERIA
''' If .Cells(i, "G").Value = "" Or .Cells(i, "G").Value = 0 Then
' .Rows(i).Delete
' End If
Next
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
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,393
Does it have to be GMAIL ? Can it be Outlook ?
 

shophoney

Active Member
Joined
Jun 16, 2014
Messages
256
Does it have to be GMAIL ? Can it be Outlook ?
We have gmail at the office.

But I can probably use another provider?

Is there an issue with Gmail?

I know depending on what app i use to view emails, that can look different.

Thanks
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,393
I am not proficient with GMAIL. It has some idiosyncrocies that Outlook does not have.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,163,471
Messages
5,831,844
Members
430,089
Latest member
beesz

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top