Send range as picture in email

Question

hey
i have the below code which sends the range in the body of an email to the addresses specified in another range. I need to ammend it so the range is pasted as a picture to preserve formatting etc??
any help is always appreciated
Tom
Sub Managermail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sTo As String
    Set emailRng = Worksheets("sheet4").Range("a1:a30")
    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next
    sTo = Mid(sTo, 2)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    Sheets("Sheet2").Select
    ActiveSheet.Range("a1:s52").Select
   ActiveWorkbook.EnvelopeVisible = True
   With ActiveSheet.MailEnvelope
   .Introduction = "WTD Update"
      .Item.TO = sTo
      .Item.Subject = "WTD Update"
      .Item.send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set emailRng = Nothing
    Set cl = Nothing
    MsgBox "Manager Email Sent"
    'Application.Run "'Wrap-CHT update.xlsm'!advisormail"
End Sub

Answer 1

hey
i have the below code which sends the range in the body of an email to the addresses specified in another range. I need to ammend it so the range is pasted as a picture to preserve formatting etc??
any help is always appreciated
Tom
Sub Managermail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sTo As String
    Set emailRng = Worksheets("sheet4").Range("a1:a30")
    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next
    sTo = Mid(sTo, 2)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    Sheets("Sheet2").Select
    ActiveSheet.Range("a1:s52").Select
   ActiveWorkbook.EnvelopeVisible = True
   With ActiveSheet.MailEnvelope
   .Introduction = "WTD Update"
      .Item.TO = sTo
      .Item.Subject = "WTD Update"
      .Item.send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set emailRng = Nothing
    Set cl = Nothing
    MsgBox "Manager Email Sent"
    'Application.Run "'Wrap-CHT update.xlsm'!advisormail"
End Sub
Copy Excel Range and then use Selection.PasteAndFormat (wdChartPicture) in Outlook's Message Editor