Add text before pasting pic in outlook

[mecerrato]

I have the following code that works most of the times, sometimes if gives me this error when using it consecutively too quickly: Run-time error 1004 CopyPucture method of range class failed.
But I guess I can live with that

What I need is to be able to add add text before the picture in the outlook mail message it pastes the picture into.

I don't know how to do that, can someone help me?

Sub ScreenShotMain()
    Dim rng As Range
    Dim olApp As Object
    Dim Email As Object
    Dim Sht As Excel.Worksheet
    Dim wdDoc As Word.Document

    Set rng = Sheets("Calc").Range("B4:C17")
        rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)
'

    With Email
        '.To = "mcerrato"
        .CC = ""
        .BCC = ""
        .Subject = "Forward Commitment" ' & Range("F5").Value
        .Display
            Set wdDoc = Email.GetInspector.WordEditor
        wdDoc.Range.PasteAndFormat Type:=wdChartPicture

'        if need setup inlineshapes height & width
         With wdDoc
            .InlineShapes(1).Height = 230
         End With

        
    End With

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

    Set Email = Nothing
    Set olApp = Nothing
End Sub

 

[DanteAmor]

Try this:

Sub ScreenShotMain()
    Dim rng As Range
    Dim olApp As Object
    Dim Email As Object
    Dim Sht As Excel.Worksheet
    Dim wdDoc As Word.Document

    Set rng = Sheets("Calc").Range("B4:C17")
        rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)

    With Email
      .To = "damor"
      .CC = ""
      .BCC = ""
      .Subject = "Forward Commitment" ' & Range("F5").Value
      .Body = "text before the picture" & vbCr & vbCr
      .Display
      DoEvents
      SendKeys "^{End}", True
      SendKeys "{Enter}", True
      SendKeys "^{v}", True
      .Display
    End With

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

    Set Email = Nothing
    Set olApp = Nothing
End Sub

 

[DanteAmor]

Also try this:

Sub ScreenShotMain()
    Dim rng As Range
    Dim olApp As Object
    Dim Email As Object
    Dim wdDoc As Word.Document
    Dim wdRng As Word.Range

    Set rng = Sheets("Calc").Range("B4:C17")
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)

    With Email
      .To = "damor"
      .CC = ""
      .BCC = ""
      .Subject = "Forward Commitment" ' & Range("F5").Value
      .Body = "text before the picture" & vbCr & vbCr
      .Display
      DoEvents
        Set wdDoc = Email.GetInspector.WordEditor
        Set wdRng = wdDoc.Application.ActiveDocument.Content
        wdRng.Collapse Direction:=wdCollapseEnd
        rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        wdRng.PasteSpecial DataType:=3
      .Display
    End With

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

    Set Email = Nothing
    Set olApp = Nothing
End Sub