troubleshooting Question

Help with a Macro to email sheet as the body that includes objects not just cells

Avatar of ghoti4t5
ghoti4t5 asked on
Microsoft Excel
12 Comments1 Solution508 ViewsLast Modified:
Hello I am trying to create a macro in excel to email a sheet (chart and other objects included) as the body of the email with personalized information per person that is taken from a list. Currently I have pieced together a macro that can email the cells of the sheet, but it skips all objects (Chart, images, and a text box) which are needed for the email to be complete.

The objects that need to be added to the email are: "Picture 10", "Text Box 8", "Picture 9", "Picture 6", "Chart 5".

The current Macro right now that only emails the cells is as follows:

Sub Info()
'
' Info Macro
' 
'
' Keyboard Shortcut: Ctrl+c
'

    Dim i As Integer
    
    NumRows = Sheets("Data Chart").Range("D5", Sheets("Data Chart").Range("D5").End(xlDown)).Rows.Count
    For i = 0 To NumRows
         If Not IsEmpty(Sheets("Data Chart").Range("D5")) Then
            Sheets("Input").Select
            Range("J2").Select
            ActiveCell.Value = Sheets("calc").Range("P2").Offset(i, 0).Value
            Range("K2").Select
            ActiveCell.Value = Sheets("calc").Range("Q2").Offset(i, 0).Value
            Range("B7").Select
            ActiveCell.Value = Sheets("calc").Range("R2").Offset(i, 0).Value
            Range("J3").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 0).Value
            Range("B10").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 4).Value
            Range("B11").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 5).Value
            Range("B12").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 6).Value
            Range("B13").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 7).Value
            Range("B14").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 8).Value
            Range("B15").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 9).Value
            Range("B16").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 10).Value
            Range("B17").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 11).Value
            Range("B18").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 12).Value
            Range("B19").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 13).Value
            Range("B20").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 14).Value
            Range("B21").Select
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 15).Value
            
    
  
' Email section
            Dim rng As Range
            Dim OutApp As Object
            Dim OutMail As Object
            With Application
                .EnableEvents = False
                .ScreenUpdating = False
            End With
         
            Set rng = Nothing
            Set rng = Sheets("Graph").UsedRange
            'You can also use a sheet name
            'Set rng = Sheets("YourSheet").UsedRange
        
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
         
            On Error Resume Next
            With OutMail
                .To = Range("N3").Value
                .CC = ""
                .BCC = ""
                .Subject = "This is the Subject line"
                .HTMLBody = RangetoHTML(rng)
                .Display   'or use  .Send
            End With
            On Error GoTo 0
         
            With Application
                .EnableEvents = True
                .ScreenUpdating = True
            End With
         
            Set OutMail = Nothing
            Set OutApp = Nothing

        End If
    Next
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") & ".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: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

Open in new window


Please note that I am using MS Excel 2003 and Outlook 2007
This will send out Emails automatically so the .Display will be changed to .Send
and the .To = Range("N3").Value is a dummy value for testing the macro
ASKER CERTIFIED SOLUTION
ghoti4t5

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 12 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 12 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros