Как скопировать диапазон ячеек в виде растровых изображений в теле письма? - PullRequest
Новая
       31

Как скопировать диапазон ячеек в виде растровых изображений в теле письма?

1 голос
/ 30 мая 2019

У меня есть 7 различных диапазонов ячеек, которые мне нужно скопировать и вставить в виде растровых изображений в моем теле электронной почты.

Диапазоны: E3, V29;е30, v54;е55, v80;e81, v145;х3, аф8;х9, аф37;e3, v180 

Sub Criaremail()

    Dim Outlook As Object
    Dim email As Object
    Dim xInspect As Object
    Dim pageEditor As Object

    assunto = Sheets("Corpo do Email").Range("AH1")
    para = Sheets("Corpo do Email").Range("AH2")

    Set Outlook = CreateObject("Outlook.application")
    Set email = Outlook.CreateItem(0)

    With email
        .Display
        .Subject = assunto
        .To = para
        .Body = ""

    Set xInspect = email.GetInspector
    Set pageEditor = xInspect.WordEditor

    Sheets("Corpo do Email").Range("E3:V29").Copy

    pageEditor.Application.Selection.Start = Len(.Body)
    pageEditor.Application.Selection.End = 
    pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.PasteSpecial (wdPasteBitmap)
    .Display

    Set pageEditor = Nothing
    Set xInspect = Nothing

    End With

    Set email = Nothing
    Set Outlook = Nothing

End Sub

1 Ответ

0 голосов
/ 30 мая 2019

Вы можете скопировать каждый из 7 диапазонов по отдельности или зациклить каждую область многодиапазона.
Я добавил две альтернативы для вставки: вставка в виде диаграммы или растрового изображения.
С моим кодом вытакже сохраните вашу подпись электронной почты по умолчанию. 

Sub Criaremail()

    Dim Outlook As Object
    Dim email As Object
    Dim xInspect As Object
    Dim pageEditor As Object
    Dim assunto As String, para As String
    Dim myRange As Excel.Range

    assunto = Sheets("Corpo do Email").Range("AH1")
    para = Sheets("Corpo do Email").Range("AH2")

    Set Outlook = CreateObject("Outlook.application")
    Set email = Outlook.CreateItem(0)

    With email
        .Subject = assunto
        .To = para

        Set xInspect = email.GetInspector
        Set pageEditor = xInspect.WordEditor

        pageEditor.Range.Characters(1).Select
        With pageEditor.Application.Selection
            .Collapse 1                 ' 1 = wdCollapseStart
            .InsertAfter "Hi," & vbCrLf & vbCrLf & _
                     "here's the info:" & vbCrLf
            .Collapse 0                 ' 0 = wdCollapseEnd
            For Each myRange In Sheets("Corpo do Email") _
                .Range( _
                "E3:V29, E30:V54, E55:V80, E81:V145, X3:AF8, X9:AF37, E3:V180" _
                ).Areas
                myRange.Copy
                '.PasteAndFormat Type:=13       ' 13 = wdChartPicture
                .PasteSpecial DataType:=4       ' 4 = wdPasteBitmap
                .InsertParagraphAfter
                .Collapse 0
            Next myRange
            .InsertAfter "Best wishes,"
            .Collapse 0
        End With
        .Display

        Set pageEditor = Nothing
        Set xInspect = Nothing

    End With

    Set email = Nothing
    Set Outlook = Nothing

End Sub
...