none
send range as picture in email RRS feed

  • 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

    Wednesday, March 18, 2015 8:19 PM

Answers

  • 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
    • Marked as answer by dude_sweet7 Wednesday, March 18, 2015 11:13 PM
    Wednesday, March 18, 2015 9:30 PM