Okay, so Ive read all the threads, and as you'll see in my (other peoples) code, spent some time on Ron's site as well. From that, I have 2 pieces of code working (3 including the function, lets call them C1 and C2), now I need help trying to mend them together.
The first one (C1) gets data from my Excel sheet and puts it nicely into an email.
The second (C2), gets a chart, and puts it in an Email.
I need to find a way to get this chart below the data produced by C1, in the same email.
A couple notes on this: Please do not recommend saving the chart as an image then importing it. Ive tried this, I need the image to appear the way it does in this code, for the purpose of it appearing on phones in the email.
I tried calling one sub from the other, but Im just not good enough at VBA to figure it out. Then I tried bringing in the C1 set of code below the C2 set. This looked like it was working at first, as it only created 1 email, but it just pasted the data from C1 over the chart from C2 and got rid of it.
Please help, been struggling with this for a while now!
Thanks!
C1:
Sub CreateMail()
Dim doData1 As DataObject, doData2 As DataObject
Dim objOutlook As Object, objMail As Object
Dim rngTo As Range, rngCc As Range, rngSubject As Range
Dim rngBody1 As Range
Dim rngBody2 As Range
Set doData1 = New DataObject
Set doData2 = New DataObject
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
'this just turns my select cells into values
Range("M9:P55").Select
Selection.Copy
Range("V9").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'get the header and paste special as a value
Range("C64").Select
Application.CutCopyMode = False
Selection.Copy
Range("V7").Select
'ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Sheets("Summary")
Set rngTo = .Range("R8")
Set rngCc = .Range("R9")
Set rngSubject = .Range("C63")
End With
Set rngBody1 = Sheets("Summary").Range("V7:z55")
rngBody1.Copy
doData1.GetFromClipboard
' Set rngBody2 = Sheets("Summary").Charts("testchart")
' rngBody2.Copy
' doData1.GetFromClipboard
With objMail
.To = rngTo.Value
.CC = rngCc.Value
.Subject = rngSubject.Value
.HTMLBody = RangetoHTML(rngBody1) '& RangetoHTML(rngBody2) '& doData1.GetText(1) & vbCrLf & doData2.GetText(1)
.display
End With
Set doData1 = Nothing
Set doData2 = Nothing
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngSubject = Nothing
Set rngBody1 = Nothing
Set rngBody2 = Nothing
End Sub
Function RangetoHTML(rng As Range)
'The mail macro needs this one to operate....
' Working in Office 2000-2013
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
ublishsource=", _
"align=left xublishsource=")
'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
C2:
Option Explicit
Sub CopyAndPasteToMailBody()
Dim mailApp, mail As Object
Dim olMailItem, wEditor As Variant
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
mail.display
Set wEditor = mailApp.ActiveInspector.wordEditor
ActiveChart.ChartArea.Copy
wEditor.Application.Selection.Paste
End Sub
The first one (C1) gets data from my Excel sheet and puts it nicely into an email.
The second (C2), gets a chart, and puts it in an Email.
I need to find a way to get this chart below the data produced by C1, in the same email.
A couple notes on this: Please do not recommend saving the chart as an image then importing it. Ive tried this, I need the image to appear the way it does in this code, for the purpose of it appearing on phones in the email.
I tried calling one sub from the other, but Im just not good enough at VBA to figure it out. Then I tried bringing in the C1 set of code below the C2 set. This looked like it was working at first, as it only created 1 email, but it just pasted the data from C1 over the chart from C2 and got rid of it.
Please help, been struggling with this for a while now!
Thanks!
C1:
Sub CreateMail()
Dim doData1 As DataObject, doData2 As DataObject
Dim objOutlook As Object, objMail As Object
Dim rngTo As Range, rngCc As Range, rngSubject As Range
Dim rngBody1 As Range
Dim rngBody2 As Range
Set doData1 = New DataObject
Set doData2 = New DataObject
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
'this just turns my select cells into values
Range("M9:P55").Select
Selection.Copy
Range("V9").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'get the header and paste special as a value
Range("C64").Select
Application.CutCopyMode = False
Selection.Copy
Range("V7").Select
'ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Sheets("Summary")
Set rngTo = .Range("R8")
Set rngCc = .Range("R9")
Set rngSubject = .Range("C63")
End With
Set rngBody1 = Sheets("Summary").Range("V7:z55")
rngBody1.Copy
doData1.GetFromClipboard
' Set rngBody2 = Sheets("Summary").Charts("testchart")
' rngBody2.Copy
' doData1.GetFromClipboard
With objMail
.To = rngTo.Value
.CC = rngCc.Value
.Subject = rngSubject.Value
.HTMLBody = RangetoHTML(rngBody1) '& RangetoHTML(rngBody2) '& doData1.GetText(1) & vbCrLf & doData2.GetText(1)
.display
End With
Set doData1 = Nothing
Set doData2 = Nothing
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngSubject = Nothing
Set rngBody1 = Nothing
Set rngBody2 = Nothing
End Sub
Function RangetoHTML(rng As Range)
'The mail macro needs this one to operate....
' Working in Office 2000-2013
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
ublishsource=", _"align=left x
ublishsource=")'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
C2:
Option Explicit
Sub CopyAndPasteToMailBody()
Dim mailApp, mail As Object
Dim olMailItem, wEditor As Variant
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
mail.display
Set wEditor = mailApp.ActiveInspector.wordEditor
ActiveChart.ChartArea.Copy
wEditor.Application.Selection.Paste
End Sub
