Email selected range in a spreadsheet

Question

What I need is emailing my colleagues certain cells (from Column A to Column Q) in Excel and the cells are shown as a picture in my email. Below is my code. However, the picture in my draft email is blank. It doesn't show the cells. the interesting thing is the picture (contains the cells I need) is copied in my clipboard and I am able to delete the blank picture and click paste. But I want to make it more automated since this Macro will be eventually available among the entire department. Could anyone help me?

Sub CAS_Reminder()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Rng As Range
    Dim LastRow As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Recipient_Name As String
    Dim StringBody As String
    Dim Manager_Name As String
    Dim RngHeight As Long
    Dim RngWidth As Long
    
    'set last row
    LastRow = Range("A1").End(xlDown).Row
    
    ' Set the range to be copied
    Set Rng = Range("A1", "Q" & LastRow)
    
    ' Copy the range and paste as picture
    Rng.CopyPicture xlScreen, xlPicture
    
    ' Create a temporary file to hold the image
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "SelectedRanges.png"
    
    ' Save the image to the temporary file
    With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width, Rng.Height)
        .Chart.Paste
        .Chart.Export FileName:=TempFilePath & TempFileName, FilterName:="PNG"
        .Delete
    End With
    
    ' Store range dimensions in variables
    RngHeight = Rng.Height
    RngWidth = Rng.Width
    
    ' Create a new email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' Set the recipients
    Recipient_Name = Range("Q2").Value & "@harriscomputer.com"
    Manager_Name = Range("D2").Value & "@harriscomputer.com"
    
    OutMail.To = Recipient_Name
    OutMail.CC = Manager_Name
    
    ' set subject of the email
    OutMail.Subject = "xxx"
    
    'set the body of the email
    StringBody = "xxx" & _
              "<img src='cid:SelectedRanges.png' height='" & RngHeight & "' width='" & RngWidth & "'>" 
    OutMail.HTMLBody = StringBody
    OutMail.Attachments.Add TempFilePath & TempFileName, 1, 0

    OutMail.Display
    
    ' Clean up
    Kill TempFilePath & TempFileName
    Set OutMail = Nothing
    Set OutApp = Nothing
    Sheets(1).Delete
    Application.DisplayAlerts = False
End Sub

I think there have been at least a couple of previous questions recently with a similar problem (copied range doesn't paste into chart object). Not sure what the fix might be but you could try putting the paste into a loop while (eg) `.Chart.drawingobjects.count = 0` — Tim Williams, May 16 '23 at 00:56

Dmitry Streblechenko · Answer 1 · 2023-05-16T22:30:42.927

1

Your code is specifying the cid attribute, but is never setting the PR_ATTACH_CONTENT_ID property on the attachment to the matching value.

Change the line

OutMail.Attachments.Add TempFilePath & TempFileName, 1, 0

to

dim attach
set attach = OutMail.Attachments.Add(TempFilePath & TempFileName)
attach.PropertyAccessor.SetProperty("http://schemas.microsoft.com/mapi/proptag
/0x3712001F", "SelectedRanges.png")

edited May 16 '23 at 22:30

answered May 16 '23 at 01:54

Dmitry Streblechenko

62,942
4
53
78

Tim Williams · Accepted Answer · 2023-05-16T22:45:12.780

Seems like the single .Paste doesn't always work - sometimes you need to try it multiple times before the chart gets populated with the image. I've seen the same type of thing when trying to paste a copied image to a worksheet (but in that case the failure generates a run-time error). See for example https://stackoverflow.com/a/60582628/478884

This works pretty consistently for me:

Sub CAS_Reminder()
    Const RNG_PIC As String = "SelectedRanges.png"
    
    Dim OutApp As Object, OutMail As Object
    Dim Rng As Range, LastRow As Long, ws As Worksheet
    Dim TempFileName As String, Recipient_Name As String
    Dim StringBody As String, Manager_Name As String
    Dim RngHeight As Long, RngWidth As Long, attach As Object
    
    Set ws = ActiveSheet
    LastRow = ws.Range("A1").End(xlDown).Row
    Set Rng = ws.Range("A1:Q" & LastRow)
    RngHeight = Rng.Height
    RngWidth = Rng.Width
    Rng.CopyPicture xlScreen, xlPicture
    
    TempFileName = Environ$("temp") & "\" & RNG_PIC
     
    With ws.ChartObjects.Add(0, 0, RngWidth, RngHeight)
        '.Chart.Paste 'pic in mail is blank....
        CheckPaste .Chart 'make sure paste succeeded
        .Chart.Export Filename:=TempFileName, FilterName:="PNG"
        .Delete
    End With
    
    Set OutApp = GetObject(, "Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    'from Dmitry...
    Set attach = OutMail.Attachments.Add(TempFileName)
    attach.PropertyAccessor.SetProperty _
       "http://schemas.microsoft.com/mapi/proptag/0x3712001F", RNG_PIC
    
    StringBody = "xxx" & _
              "<img src='cid:" & RNG_PIC & "' height='" & RngHeight & "' width='" & RngWidth & "'>"
    OutMail.HTMLBody = StringBody
    
    OutMail.Display
End Sub

'try >1 paste if needed....
Sub CheckPaste(cht As Chart)
    Dim i As Long
    Do While cht.DrawingObjects.Count = 0 And i < 5
        cht.Paste
        DoEvents
        i = i + 1
    Loop
    Debug.Print "Paste count= " & i
End Sub

score 0 · Answer 3 · answered May 16 '23 at 02:54

try

Sub SendEmailWithRange()
    Dim MyRange As Range
    Dim doc As Object, x
    Dim LastRow As Long
    
    LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
    Set MyRange = Sheets(1).Range("A1:Q" & LastRow)
    
    With CreateObject("outlook.application").CreateItem(0)
        .Display   'Change to .Send to send the email immediately
        
        .Body = "xxx"  '& vbNewLine
        Set doc = .GetInspector.WordEditor
        
        x = doc.Range.End - 1
        MyRange.Copy
        doc.Range(x).Paste
            
        .To = Sheets(1).Range("Q2").Value & "@harriscomputer.com"
        .CC = Sheets(1).Range("D2").Value & "@harriscomputer.com"
        .Subject = "xxx"
        
        Application.CutCopyMode = 0
    End With
    
    Sheets(1).Delete
End Sub

Email selected range in a spreadsheet

3 Answers3