cgmorgan
05-04-2011, 03:47 PM
Hello all,
I am having some trouble with this particular issue. I have a pivot chart (excel object) and some cells with data that I'm wanting to copy and paste into an e-mail and have it sent automatically.
The problem I am having with it is, it doesn't keep my cell formatting (color, etc) and it doesn't paste in my pivot chart (i'm assuming because its an object, not data in a cell).
I had to eliminate some of the stuff in my coding due to company privacy issues but this is what I have so far.
Any help would be great.
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim strdate As String: strdate = Format(Now, "mm-dd-yy")
'ActiveWorkbook.Save
'MsgBox "File Saved! Please remember to include any additional contacts for the day in the e-mail distribution list!", vbCritical, "IMPORTANT!"
'Remove screen updating
Application.ScreenUpdating = False
Set rng = Worksheets("Dashboard").Range("A1:E31")
Response = MsgBox(prompt:="Are you sure you want to send an email?", Buttons:=vbYesNo, Title:="Send Email")
If Response = vbNo Then
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "email lists here"
.CC = "and here"
.BCC = "and here"
.Subject = "Subject here " & strdate
'.body = ""
.HTMLBody = RangetoHTML(rng)
'.Attachments.Add ActiveWorkbook.FullName
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Add screen updating
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
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.CloseRangetoHTML = Replace(RangetoHTML, "align=center xlpublishsource=", _
"align=left xlpublishsource=")
'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
I am having some trouble with this particular issue. I have a pivot chart (excel object) and some cells with data that I'm wanting to copy and paste into an e-mail and have it sent automatically.
The problem I am having with it is, it doesn't keep my cell formatting (color, etc) and it doesn't paste in my pivot chart (i'm assuming because its an object, not data in a cell).
I had to eliminate some of the stuff in my coding due to company privacy issues but this is what I have so far.
Any help would be great.
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim strdate As String: strdate = Format(Now, "mm-dd-yy")
'ActiveWorkbook.Save
'MsgBox "File Saved! Please remember to include any additional contacts for the day in the e-mail distribution list!", vbCritical, "IMPORTANT!"
'Remove screen updating
Application.ScreenUpdating = False
Set rng = Worksheets("Dashboard").Range("A1:E31")
Response = MsgBox(prompt:="Are you sure you want to send an email?", Buttons:=vbYesNo, Title:="Send Email")
If Response = vbNo Then
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "email lists here"
.CC = "and here"
.BCC = "and here"
.Subject = "Subject here " & strdate
'.body = ""
.HTMLBody = RangetoHTML(rng)
'.Attachments.Add ActiveWorkbook.FullName
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Add screen updating
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
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.CloseRangetoHTML = Replace(RangetoHTML, "align=center xlpublishsource=", _
"align=left xlpublishsource=")
'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