如何创建Outlook电子邮件并调整所有图像的大小

Question

下面的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

Answer 1

您已经在使用Word对象，因此使用内联形状的InlineShapes属性height/Width

示例

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