vba 在 Outlook 中粘贴 Excel 范围

Paste Excel range in Outlook

提问by Gilbert Jacob

I want to paste a range of cells in Outlook.

我想在 Outlook 中粘贴一系列单元格。

Here is my code:

这是我的代码：

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, xlTextValues)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If

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

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

On Error Resume Next
With OutMail
    .To = ThisWorkbook.Sheets("Sheet2").Range("C1").Value
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangeToHtml.rng
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

I am not getting any error, it just does not paste range in Outlook.

我没有收到任何错误，只是没有在 Outlook 中粘贴范围。

I have removed the On Error Resume Next. It gives me an error

我已经删除了On Error Resume Next. 它给了我一个错误

Object doesn't support this property or method.

对象不支持此属性或方法。

回答by Paul-Jan

First off, RangeToHTML. The script calls it like a method, but it isn't. It's a popular functionby MVP Ron de Bruin. Coincidentally, that links points to the exact source of the script you posted, before those few lines got b?u?t?c?h?e?r?e?d? modified.

首先，RangeToHTML。脚本像方法一样调用它，但它不是。这是MVP Ron de Bruin的一项流行功能。巧合的是，在这几行得到 b?u?t?c?h?e?r?e?d 之前，该链接指向您发布的脚本的确切来源。修改的。

On with Range.SpecialCells. This method operates on a range and returns only those cells that match the given criteria. In your case, you seem to be only interested in the visible textcells. Importantly, it operates on a Range, not on HTML text.

使用Range.SpecialCells。此方法对范围进行操作并仅返回与给定条件匹配的单元格。在您的情况下，您似乎只对可见文本单元格感兴趣。重要的是，它在Range上运行，而不是在 HTML 文本上运行。

For completeness sake, I'll post a working version of the script below. I'd certainly advise to disregard it and revisit the excellent original by Ron the Bruin.

为了完整起见，我将在下面发布脚本的工作版本。我当然建议忽略它并重新审视 Ron the Bruin 的优秀原作。

Sub Mail_Selection_Range_Outlook_Body()

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("Sheet1").Range("D4:D12").SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If

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

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


With OutMail
    .To = ThisWorkbook.Sheets("Sheet2").Range("C1").Value
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .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

回答by David Zemens

Often this question is asked in the context of Ron de Bruin's RangeToHTMLfunction, which creates an HTML PublishObjectfrom an Excel.Range, extracts that via FSO, and inserts the resulting stream HTML in to the email's HTMLBody. In doing so, this removes the default signature (the RangeToHTMLfunction has a helper function GetBoilerwhich attempts to insert the default signature).

通常在 Ron de BruinRangeToHTML函数的上下文中会问这个问题，该函数PublishObject从中创建一个 HTML Excel.Range，通过 FSO 提取它，并将结果流 HTML 插入到电子邮件的HTMLBody. 这样做时，这会删除默认签名（该RangeToHTML函数有一个帮助函数GetBoiler尝试插入默认签名）。

Unfortunately, the poorly-documented Application.CommandBarsmethod is not available via Outlook:

不幸的是，Application.CommandBars无法通过 Outlook 使用记录不足的方法：

wdDoc.Application.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

It will raise a runtime 6158:

它将引发运行时 6158：

But we can still leverage the Word.Documentwhich is accessible via the MailItem.GetInspectormethod, we can do something like this to copy & paste the selection from Excel to the Outlook email body, preserving your default signature (if there is one).

但是我们仍然可以利用Word.Document可通过该MailItem.GetInspector方法访问的，我们可以执行类似的操作，将 Excel 中的选择复制并粘贴到 Outlook 电子邮件正文中，同时保留您的默认签名（如果有）。

Dim rng as Range
Set rng = Range("A1:F10") 'Modify as needed

With OutMail
    .To = "[email protected]"
    .BCC = ""
    .Subject = "Subject"
    .Display
    Dim wdDoc As Object     '## Word.Document
    Dim wdRange As Object   '## Word.Range
    Set wdDoc = OutMail.GetInspector.WordEditor
    Set wdRange = wdDoc.Range(0, 0)
    wdRange.InsertAfter vbCrLf & vbCrLf
    'Copy the range in-place
    rng.Copy
    wdRange.Paste
End With

Note that in some cases this may not perfectly preserve the column widths or in some instances the row heights, and while it will also copy shapes and other objects in the Excel range, this may also cause some funky alignment issues, but for simple tables and Excel ranges, it is very good:

请注意，在某些情况下，这可能无法完美地保留列宽或在某些情况下保留行高，虽然它还会复制 Excel 范围内的形状和其他对象，但这也可能会导致一些奇怪的对齐问题，但对于简单的表格和Excel范围，非常好：