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

Question

我正在从Excel创建Outlook电子邮件（Office 2013）。我想将一系列单元格（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 ＆gt; 参考文献...... ＆gt;设置这样的复选标记：

或者，您可以忘记引用并使用后期绑定，声明所有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