Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

Professional Opinions
Ask a Question
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

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
            ActiveCell.Value = Sheets("calc").Range("P2").Offset(i, 0).Value
            ActiveCell.Value = Sheets("calc").Range("Q2").Offset(i, 0).Value
            ActiveCell.Value = Sheets("calc").Range("R2").Offset(i, 0).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 0).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 4).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 5).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 6).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 7).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 8).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 9).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 10).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 11).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 12).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 13).Value
            ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 14).Value
            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
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
    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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        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, _
        .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
    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

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
Avatar of ghoti4t5

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

This problem has been solved!
Unlock 1 Answer and 12 Comments.
See Answers