×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!
  • Students Click Here

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Jobs

Problems with Excel attaching a jpg within a send email routine

Problems with Excel attaching a jpg within a send email routine

Problems with Excel attaching a jpg within a send email routine

(OP)
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

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=""https://some 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 

CODE

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 

RE: Problems with Excel attaching a jpg within a send email routine

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

Skip,

glassesJust traded in my OLD subtlety...
for a NUance!tongue

RE: Problems with Excel attaching a jpg within a send email routine

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

RE: Problems with Excel attaching a jpg within a send email routine

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

Skip,

glassesJust traded in my OLD subtlety...
for a NUance!tongue

RE: Problems with Excel attaching a jpg within a send email routine

I am guessing what Skip is saying is:

CODE

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

And I would strongly suggest Option Explicit at the top of your code.


---- Andy

There is a great need for a sarcasm font.

RE: Problems with Excel attaching a jpg within a send email routine

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,

glassesJust traded in my OLD subtlety...
for a NUance!tongue

RE: Problems with Excel attaching a jpg within a send email routine

(OP)
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.

RE: Problems with Excel attaching a jpg within a send email routine

(OP)
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 smile

RE: Problems with Excel attaching a jpg within a send email routine

Give this a try...

CODE

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,

glassesJust traded in my OLD subtlety...
for a NUance!tongue

RE: Problems with Excel attaching a jpg within a send email routine

(OP)
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.

CODE

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=""https://...""> 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 

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Tek-Tips forums is a member-only feature.

Click Here to join Tek-Tips and talk with other members! Already a Member? Login

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close