将 Excel 范围作为图片粘贴到电子邮件中

Question

我正在从 Excel (Office 2013) 创建 Outlook 电子邮件。我想将一系列单元格 (C3:S52) 作为图片粘贴到电子邮件中。

下面是我到目前为止的代码。我哪里错了？

 Sub Button193_Click()
 '
 ' Button193_Click Macro
 '

 '
 ActiveWindow.ScrollColumn = 2
 ActiveWindow.ScrollColumn = 1
 Range("C3:S52").Select
 Selection.Copy
 End Sub
 Sub CreateMail()

 Dim objOutlook As Object
 Dim objMail As Object
 Dim rngTo As Range
 Dim rngSubject As Range
 Dim rngBody As Range
 Dim rngAttach As Range

 Set objOutlook = CreateObject("Outlook.Application")
 Set objMail = objOutlook.CreateItem(0)

 With ActiveSheet
 Set rngTo = .Range("E55")
 Set rngSubject = .Range("E56")
 Set rngBody = .Range("E57")
 End With

 With objMail
 .To = rngTo.Value
 .Subject = rngSubject.Value
 .Body = rngBody.Value
 .Display 'Instead of .Display, you can use .Send to send the email _
 or .Save to save a copy in the drafts folder
 End With

 Set objOutlook = Nothing
 Set objMail = Nothing
 Set rngTo = Nothing
 Set rngSubject = Nothing
 Set rngBody = Nothing
 Set rngAttach = Nothing

 End Sub
 Sub Button235_Click()
 '
 ' Button235_Click Macro
 '

 '
 ActiveWindow.ScrollColumn = 2
 ActiveWindow.ScrollColumn = 1
 Range("A1:M27").Select
 Selection.Copy
 End Sub
 Sub RunThemAll()

 Application.Run "Button193_Click"

 Application.Run "CreateMail"

 End Sub 

Answer 1

这是一个工作示例，在 Office 2010 中测试：

'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy

'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor

'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture

'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False

结果：

在上面的代码中，我使用了早期绑定来访问自动完成；要使用此代码，您需要设置对 Microsoft Outlook 和 Microsoft Word 对象库的引用：Tools > References... > 像这样设置复选标记：

或者，您可以忘记引用并使用后期绑定，声明所有 Outlook 和 Word 对象 As Object 而不是 As Outlook.Application 和 As Word.Document 等。

---

显然您在执行上述操作时遇到了困难；范围粘贴为表格而不是电子邮件中的图片。我无法解释为什么会发生这种情况。

另一种方法是在 Excel 中粘贴为图像，然后将该图像剪切并粘贴到您的电子邮件中：

'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy

'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut

'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor

'Paste picture
wordDoc.Range.Paste

正如WizzleWuzzle所指出的，也可以选择使用PasteSpecial而不是PasteAndFormat或Paste...

wordDoc.Range.PasteSpecial , , , , wdPasteBitmap

...但由于某种原因，生成的图像也无法渲染。看看下面的桌子是怎么模糊的：

Answer 2

我正在为上述问题提供替代解决方案，因为 Outlook.MailItem.GetInspector.WordEditor 在某些组织环境中不起作用。

出于安全目的，HTMLBody、HTMLEditor、Body 和 WordEditor 属性都受地址信息安全提示的影响，因为邮件正文通常包含发件人或其他人的电子邮件地址。而且，如果组策略不允许，则这些提示不会出现在屏幕上。简单来说，作为一个开发者，你必须要修改你的代码，因为既不能修改注册表，也不能修改组策略。

因此，如果您的代码在迁移到 Office 365 后突然停止工作或由于任何其他原因，请参考下面的代码。添加了注释以便于理解和实施。

如果您拥有管理权限，请尝试以下链接中的注册表更改： https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

但是，作为开发人员，我建议使用与所有 Excel 版本相当兼容的代码，而不是进行系统更改，因为每个最终用户的计算机也需要进行系统更改。

代码兼容：Excel 2003、Excel 2007、Excel 2010、Excel 2013、Excel 2016、Office 365

---

Option Explicit

Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)


    Dim rngToPicture As Range
    Dim outlookApp As Object
    Dim Outmail As Object
    Dim strTempFilePath As String
    Dim strTempFileName As String

    'Name it anything, doesn't matter
    strTempFileName = "RangeAsPNG"

    'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
    Set rngToPicture = Range("rngToPicture")
    Set outlookApp = CreateObject("Outlook.Application")
    Set Outmail = outlookApp.CreateItem(olMailItem)

    'Create an email
    With Outmail
        .To = strTo
        .Subject = strSubject

        'Create the range as a PNG file and store it in temp folder
        Call createPNG(rngToPicture, strTempFileName)

        'Embed the image in Outlook
        strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
        .Attachments.Add strTempFilePath, olByValue, 0

        'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
        .HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"


        .Display

    End With

    Set Outmail = Nothing
    Set outlookApp = Nothing
    Set rngToPicture = Nothing

End Sub

Sub createPNG(ByRef rngToPicture As Range, nameFile As String)

    Dim wksName As String

    wksName = rngToPicture.Parent.Name

    'Delete the existing PNG file of same name, if exists
    On Error Resume Next
        Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0

    'Copy the range as picture
    rngToPicture.CopyPicture

    'Paste the picture in Chart area of same dimensions
    With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        'Export the chart as PNG File to Temp folder
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete

End Sub