Search code examples
excelvbaoutlookms-word

Send screenshot of Excel range in an email keeping signature


I am trying to send a screenshot of an Excel range in an email using VBA. When it pastes the screenshot it removes the signature.

I have other worksheets that send the range and keep the signature. It seems attaching an image is causing the issue.

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 = "[email protected]"
            .Cc = "[email protected]"
            .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 = "[email protected]"
            .Cc = "[email protected]"
            .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