Pasting Graphs into multiple emails

user_18391578 0
Viewed 57

I have a spreadsheet that records performance data for each employee each month.

I run VBA code on selected employees data to create an email for each employee. The email contains their performance data for the previous month but the code also creates a year to date graph which it then pastes on the email.

I have 2 problems.

  1. The graph pastes at the top of the email. How do I add it to the bottom?

  2. When I run the code for more than one employee it adds the graph for the last employee whose email was generated.
    The code that creates the email sits within a loop for each employee selected.
    The code that creates the graph sits within this loop as it pulls each employee's data into a table that the graph is made from.
    All I can think is that the graph that is pasted into the email is using the data that currently sits in the table on the spreadsheet rather than the data that was there at the time the graph was created.

The main code that creates the email:

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim selectedMonth As String
Dim emAddy As String
selectedMonth = Sheets("Control Panel").Range("E4").Value

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'generate graphs

Dim sh As Variant
Set Rng = Range("B1:M12")
For Each sh In Array("April", "May", "June", "July", "August", "September", "October", "November", "December", "January", "February", "March") 
    lastrow = Sheets(sh).Range("A" & Rows.Count).End(xlUp).Row
    For m = 1 To lastrow
        If Sheets(sh).Range("A" & m).Value = staffList.List(i) Then
            For N = 2 To 13
                If Sheets("graphs").Cells(1, N).Value = sh And Sheets(sh).Range("L" & m).Value <> "NaN" Then
                    Sheets("graphs").Cells(2, N).Value = FormatPercent(Sheets(sh).Range("L" & m).Value): N = 13
                End If
            Next N
            m = lastrow
        End If
    Next m
Next sh
    
On Error Resume Next
With OutMail
    .From = ""
    .To = emAddy
    .CC = ""
    .BCC = ""
    .Subject = "Monthly Stats"
    .HTMLbody = strbody
    .Display
End With
On Error GoTo 0

Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
    
Set wEditor = mailApp.ActiveInspector.WordEditor
Sheets("graphs").ChartObjects("Chart 1").Copy
    
wEditor.Application.Selection.Paste
vba excel
1 Answers

You have to do a little work to make sure you have an allowable WordEditor (see this documentation) and then to move the insertion point to the end of the document. The example here shows how:

Option Explicit

Sub TestEmailWithChart()
    Dim theChart As ChartObject
    Set theChart = Sheet1.ChartObjects(1)
    theChart.CopyPicture
    
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application
    
    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    
    Dim mailBody As String
    mailBody = "Hello,<br><br>Here is the chart:<br><br><br>"
    
    With olMail
        .To = "somebody@somedomain.com"
        .CC = vbNullString
        .BCC = vbNullString
        .Subject = "Test Email with Chart"
        .HTMLBody = mailBody
        
        With .GetInspector
            If .IsWordMail And (.EditorType = olEditorWord) Then
                Dim mailDoc As Word.Document
                Set mailDoc = .WordEditor
                mailDoc.Application.Selection.EndKey Unit:=wdStory
                mailDoc.Application.Selection.Paste
            Else
                Debug.Print "Can't use the Word Editor for this email"
            End If
        End With
        
        .Display
    End With
End Sub
user_47177550
Related