将 Excel 范围作为图片复制到 Outlook

Question

如何使用您在 Excel 中从右键菜单访问的“选择性粘贴 - 作为图片”命令？

我看过各种帖子，但是在使用Excel 2016时似乎已经过时了。似乎必须在这个部分，

With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select

如何更改以允许复制和粘贴为图片？

使用下面的原始代码时，我会丢失电子邮件正文中的所有列和行大小。

Dim rng As Range
Dim OutApp As Object
Dim outMail As Object

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("Dashboard").Range("B4:L17").SpecialCells(xlCellTypeVisible)

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)

With outMail
    .To = ""
    .CC = ""
    .BCC = ""
    .Subject = ""
    .HTMLBody = RangetoHTML(rng)
    .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set outMail = Nothing
Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

如果要添加文本，请使用此代码。

Dim ol As Object 'Outlook.Application
Dim olEmail As Object 'Outlook.MailItem
Dim olInsp As Object 'Outlook.Inspector
Dim wd As Object 'Word.Document

Sheets("Dashboard").Range("B4:L17").SpecialCells(xlCellTypeVisible).Copy

Set ol = GetObject(, "Outlook.Application") '/* if outlook is running, create otherwise */
Set olEmail = ol.CreateItem(0) 'olMailItem

With olEmail
    Set olInsp = .GetInspector
    If olInsp.EditorType = 4 Then 'olEditorWord
        Set wd = olInsp.WordEditor
        wd.Range.PasteAndFormat 13 'wdChartPicture
    End If

    wd.Paragraphs(1).Range.InsertAfter "Hi, There" & Chr(10)

    Sheets("chart").Range("B4:L17").SpecialCells(xlCellTypeVisible).Copy
    wd.Paragraphs(wd.Paragraphs.Count).Range.Characters.First.PasteAndFormat 13
    wd.Paragraphs.Add

    Sheets("chart").Range("B4:L17").SpecialCells(xlCellTypeVisible).Copy
    wd.Paragraphs(wd.Paragraphs.Count).Range.Characters.First.PasteAndFormat 13
    wd.Paragraphs.Add

    wd.Paragraphs(wd.Paragraphs.Count).Range.InsertAfter Chr(10) & Chr(10) & "BR"

    .Display
End With

Answer 2

这样的事情应该可以工作：

Dim ol As Object 'Outlook.Application
Dim olEmail As Object 'Outlook.MailItem
Dim olInsp As Object 'Outlook.Inspector
Dim wd As Object 'Word.Document

Sheets("Dashboard").Range("B4:L17").SpecialCells(xlCellTypeVisible).Copy

Set ol = GetObject(, "Outlook.Application") '/* if outlook is running, create otherwise */
Set olEmail = ol.CreateItem(0) 'olMailItem

With olEmail
    Set olInsp = .GetInspector
    If olInsp.EditorType = 4 Then 'olEditorWord
        Set wd = olInsp.WordEditor
        wd.Range.PasteAndFormat 13 'wdChartPicture
    End If
    .Display
End With

如果确定您的 Outlook 版本使用 Word 编辑器，您可以这样做：

With olEmail
    .GetInspector.WordEditor.Range.PasteAndFormat 13
    .Display
End With

Answer 3

要更好地了解 Outlook，请使用 Word object model with MailItem.GetInspector Property (Outlook)

例子

Option Explicit
Public Sub Example()
    Dim rng As Range
    Dim olApp As Object
    Dim Email As Object
    Dim Sht As Excel.Worksheet
    Dim wdDoc As Word.Document

    Set Sht = ActiveWorkbook.Sheets("Dashboard")
    Set rng = Sht.Range("B4:L17")
        rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set Email = olApp.CreateItem(0)
    Set wdDoc = Email.GetInspector.WordEditor

    With Email
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Attachments.Add ActiveWorkbook.FullName

         wdDoc.Range.PasteAndFormat Type:=wdChartPicture

'        if need setup inlineshapes hight & width
         With wdDoc
            .InlineShapes(1).Height = 130
         End With

        .Display
    End With

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set Email = Nothing
    Set olApp = Nothing
End Sub