Как создать электронную почту Outlook и изменить размер всех изображений - PullRequest
Новая
       9

Как создать электронную почту Outlook и изменить размер всех изображений

0 голосов
/ 17 марта 2020

Макрос Excel, приведенный ниже, прекрасно работает, за исключением того, что изображения в диапазоне Excel, которые вставляются в тело, изменяют размер (большинство из них до 55%).

Я не могу понять, что не так.

Если я вручную скопирую тот же диапазон и вставлю его в электронное письмо, изображение останется без изменений. 

Sub mailpaste()


Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim xlSheet As Worksheet
Dim wdDoc As Object
Dim oRng As Object
Dim rngTo As Range
Dim rngSubject As Range

    Application.Range("Report").copy

    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    With ActiveSheet
    Set rngTo = .Range("AA12")
    Set rngSubject = .Range("AA15")
    End With

    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .BodyFormat = 2
        .To = rngTo.Value
        .CC = ""
        .BCC = ""
        .Subject = rngSubject.Value
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.collapse 1
        oRng.Paste
        .Display
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing


End Sub

1 Ответ

0 голосов
/ 18 марта 2020

Вы уже используете объект Word, поэтому работайте со свойством InlineShapes, высотой / шириной встроенной фигуры

Пример 

    Set OutMail = OutApp.CreateItem(0)
    Set wdDoc = OutMail.GetInspector.WordEditor

    With OutMail
        .BodyFormat = 2
        .To = rngTo.Value
        .CC = ""
        .BCC = ""
        .Subject = rngSubject.Value
        .Display

         wdDoc.Range.PasteAndFormat Type:=wdChartPicture

         With wdDoc
            .InlineShapes(1).Height = 130
            .InlineShapes(1).Width = 130
         End With


    End With
...