Problems with Excel attaching a jpg within a send email routine

[LGMan]

Hi all, a co-worker has moved on and the ownership of a VBA routine that copies a range of cells with Excel and turns that range into a jpeg to added into an email has been passed to me.
The routine loops through a list of managers which changes the data in the range for each new email. The problem that I've been having is that some of the emails contain an empty frame where the picture should be. It doesn't happen for every email, but I've had to set the routine to .display instead of .send and manually check each email and send them manually.
Also the routine falls over occasionally in the Sub createJpg exec at the line for Plage.CopyPicture

Hopefully one of you good peeps can spot something or have a different way of adding the jpeg to the email. Thanks

here's the full code

Sub Send_eMail()
Dim Seldate As Date
Dim TempFilePath As String, selectedouc As String
Dim thisWB As Workbook
Dim shtname As String, selemail As String
Dim EmailFrm As String, FirstName As String
Dim EmailExtraMessage1 As String, EmailExtraMessage2 As String

EmailExtraMessage1 = Sheets("EMAILS").Range("EmailExtraMessage1")
EmailExtraMessage2 = Sheets("EMAILS").Range("EmailExtraMessage2")
EmailExtraMessage3 = Sheets("EMAILS").Range("EmailExtraMessage3")
EmailExtraMessage4 = Sheets("EMAILS").Range("EmailExtraMessage4")
  
       Set thisWB = ThisWorkbook
       shtname = "EMAILS"
       EmailFrm = thisWB.Sheets("EMAILs").Range("D2")
       selectedouc = Range("selectedframesouc")
       seldate = Range("seldate")
       selemail = Range("selframesemail")
       FirstName = Range("FirstName")
       'Create a new Microsoft Outlook session
       Set appOutlook = CreateObject("outlook.application")
       'create a new message
      Set Message = appOutlook.CreateItem(olMailItem)
       With Message
           .Subject = "Exchange Performance: " & selectedouc & " - " & seldate & ""
           .HTMLBody = "<span LANG=EN>" _
            & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
            & "Hello " & FirstName & "," & "<br>" & EmailExtraMessage1 & "<br>" _
            & "" & EmailExtraMessage2 _
            & "<br>" _
            & "" & EmailExtraMessage3 _
            & "<br>" _
            & "" & EmailExtraMessage4 _
            & "<br>" _
            & " <br >Click the attached link to download the full file " _
            & "<a href=""[URL unfurl="true"]https://some[/URL] sharepoint address"">some report name</a></b>" _

           Sheets("EMAILs").Select
           Call createJpg(shtname, "J6:AB65", "summaryfile")
           TempFilePath = Environ$("temp") & "\"
           .Attachments.Add TempFilePath & "summaryfile.jpg", olByValue, 0
           .HTMLBody = .HTMLBody & "<br>" _
             & "<img src='cid:summaryfile.jpg'" & "width='880' height='300'><br>" _
             & "<br>Regards,<br>Exchange Production Planning </font></span>"
           .SentOnBehalfOfName = EmailFrm
           .To = selemail
           .Cc = ""
           .Display

       End With
       With Application
          .ScreenUpdating = True
          .EnableEvents = True
       End With

       Application.Calculation = xlCalculationAutomatic

End Sub

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    ThisWorkbook.Activate
    Application.Wait (Now + TimeValue("00:00:01"))
    Worksheets(Namesheet).Activate
    Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    Plage.CopyPicture
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With

    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete

Set Plage = Nothing

End Sub

 

[SkipVought]

Check that the passed sheet name & range name each actually exit TOGETHER.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[LGMan]

Hi Skip, am not sure I understand what you mean.

 

[SkipVought]

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)


Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Andrzejek]

I am guessing what Skip is saying is:

...
Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)[blue]
If Plage Is Nothing Then
    MsgBox "Something wrong here."
End If[/blue]
...

And I would strongly suggest [tt]Option Explicit[/tt] at the top of your code.


---- Andy

There is a great need for a sarcasm font.

 

[SkipVought]

At the place where the routine fails, do you have that Range Name on that Sheet Name? I’d guess that the answer is “No!”

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[LGMan]

Hi, Skip, yep all the ranges exist on the sheet where the range of cells that are copied into a jpeg exist.
I've been testing what has been suggested and stepping through the code, but it all looks to go through ok until I look at the emails and out of 38, 2 of them just had the outline of where the jpeg would be.
The next time I ran it, all 38 were ok.
I'll continue to run it tomorrow until I can catch the error when it falls over at the Plage.Copy Picture line.

 

[LGMan]

thanks Skip, I'll give that a go, its 21:29 in brixitland so I'll report back in what will be tomorrow for me

 

[SkipVought]

Give this a try...

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    With ThisWorkbook.Worksheets(Namesheet)
    
        Set Plage = .Range(nameRange)
        Plage.CopyPicture
        
        With .ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height)
            .Chart.Paste
            .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
        End With
    
        .ChartObjects(.ChartObjects.Count).Delete
    End With
    
    Set Plage = Nothing
End Sub

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[LGMan]

Hi, had to change the code, however I think my laptop may have something to do with why the original code caused intermittent failures.

I've sent a run of 70 without issue. Also added an error catch incase it fails so it should try again, however this has not been tested as all my tests have worked as expected.

Sub PrepareEmail()

    Dim mailApp As Object
    Dim mail As Object
    Dim MWB As Workbook
    Dim DashWS As Worksheet
    Dim selemail As String
    Dim selectedTeam As String
    Dim EBody As String
    Dim plage As Range
    Dim path As String
    Dim EmailExtraMessage1 As String
    Dim EmailExtraMessage2 As String
    Dim EmailExtraMessage3 As String
    Dim EmailExtraMessage4 As String
    Dim FirstName As String

' Set the main objects
    Set MWB = ThisWorkbook
    Set DashWS = MWB.Sheets("Emails")
    shtname = "EMAILS"
    EmailFrm = MWB.Sheets("EMAILs").Range("D2")
    selectedTeam = Range("selectedTeam")
    Set mailApp = CreateObject("Outlook.Application")
    Set mail = mailApp.CreateItem(olMailItem)
    FirstName = Range("FirstName")
    seldate = Range("seldate")
    selemail = Range("selTeamsemail")
    EmailExtraMessage1 = Sheets("EMAILS").Range("EmailExtraMessage1")
    EmailExtraMessage2 = Sheets("EMAILS").Range("EmailExtraMessage2")
    EmailExtraMessage3 = Sheets("EMAILS").Range("EmailExtraMessage3")
    EmailExtraMessage4 = Sheets("EMAILS").Range("EmailExtraMessage4")

' Prepare any images
        i = 1
TryAgain:
    On Error GoTo ErrorCatch
    DoEvents
    Set plage = ThisWorkbook.Sheets("Emails").Range("J6:AB65")
        plage.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With ThisWorkbook.Worksheets("Emails").ChartObjects.Add(plage.Left, plage.Top, plage.Width - 400, plage.Height - 500)
        .Activate
        .Chart.Paste
        .Chart.Export path & "Dashboard.png", "PNG"
    End With
    ThisWorkbook.Worksheets("Emails").ChartObjects(Worksheets("Emails").ChartObjects.Count).Delete
    Set plage = Nothing

' Prepare the Email
    mail.display
    mail.To = selemail
    mail.Subject = "Team Performance: " & selectedTeam & " - " & seldate & ""

' Set the email greeting and initial paragraph
    EBody = "<html><p style='font-family:'Tahoma',Arial,font-size:10pt'>"
    EBody = EBody + "Hello " & FirstName & "," & "<br>" & EmailExtraMessage1 & "<br>" _
                & "" & EmailExtraMessage2 _
                & "<br>" _
                & "" & EmailExtraMessage3 _
                & "<br>" _
                & "" & EmailExtraMessage4 _
                & "<br>" _
                & " <br >Click the attached link to download the full file " _
                & "<a href=""[URL unfurl="true"]https://..."">[/URL] Performance Report</a></b>" _
                & "<br>" _
                & "<br ><B>" & selectedTeam & " Performance Report Summary for " & seldate & "</B>" _

' Insert the report summary and images
    With DashWS
        EBody = EBody + "<b><u>" & DashWS.Range("B2").Value & "</u></b><br />" & _
               .Range("B3").Value & "<br />" & _
                "<img src='" & path & "Dashboard.png" & "'><br /><br />"

    End With

' Create the email and send
    mail.HTMLBody = EBody & mail.HTMLBody
    mail.send

Exit Sub

ErrorCatch:
    i = i + 1

   If i >= 10 Then

        Exit Sub
    Else
        GoTo TryAgain

    End If

End Sub