excelvbaoutlookms-word

Trying to send screenshot of excel in an email


I am trying to send a screenshot of an excel range in an email using VBA, however when it pastes the screenshot it removes the signature. I have other worksheets that send the range and keep the signature just fine, but it seems attaching an image is causing issues.

Sub send_email_with_table_as_pic()

Dim OutApp As Object
Dim OutMail As Object
Dim table As Range
Dim pic As Picture
Dim ws As Worksheet
Dim wordDoc


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

'grab table, convert to image, and cut
Set ws = ThisWorkbook.Sheets("XXX")
Set table = ws.Range("A1:J31")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste

pic.Cut

'create email message
On Error Resume Next
    With OutMail
        .To = "xx@xxx.com"
        .Cc = "xx@xxx.com"
        .BCC = ""
        .Subject = "XXXXX " & Format(Now - 1, "mm-dd-yy")
        .Display
    
        Set wordDoc = OutMail.GetInspector.WordEditor
            With wordDoc.Range
                .PasteandFormat wdChartPicture
                .InsertBefore ""
                .insertParagraphBefore
                .InsertAfter ""
                .insertParagraphAfter
            End With
        .HTMLBody = "Hello, <Tab> Please see the below: <Tab> " & .HTMLBody
    End With
    On Error GoTo 0

Set OutApp = Nothing
Set OutMail = Nothing

End Sub

Solution

  • One thing needs to keep the signature. Defining the Range of the insertion point like this:

    With wordDoc.Range(1, 1)

    Sub send_email_with_table_as_pic()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim table As Range
    Dim pic As Picture
    Dim ws As Worksheet
    Dim wordDoc
    
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'grab table, convert to image, and cut
    Set ws = ThisWorkbook.Sheets("XXX")
    Set table = ws.Range("A1:J31")
    ws.Activate
    table.Copy
    Set pic = ws.Pictures.Paste
    
    pic.Cut
    
    'create email message
    On Error Resume Next
        With OutMail
            .To = "xx@xxx.com"
            .Cc = "xx@xxx.com"
            .BCC = ""
            .Subject = "XXXXX " & Format(Now - 1, "mm-dd-yy")
            .Display
        
            Set wordDoc = OutMail.GetInspector.WordEditor
                With wordDoc.Range(1, 1)           'edited
                    .PasteandFormat wdChartPicture
                    .InsertBefore ""
                    .insertParagraphBefore
                    .InsertAfter ""
                    .insertParagraphAfter
                End With
            .HTMLBody = "Hello, <Tab> Please see the below: <Tab> " & .HTMLBody
        End With
        On Error GoTo 0
    
    Set OutApp = Nothing
    Set OutMail = Nothing
    
    End Sub