在Outlook中粘贴特定的Excel范围

我正在处理一个我想要自动化的excel报告，但是单元格的范围并没有被粘贴到Outlook中。

这是我的代码：

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 

我没有得到任何错误，只是它不会在Outlook中粘贴范围。 谢谢。

Answer 1

首先， RangeToHTML 。 该脚本将其称为一种方法 ，但事实并非如此。 这是MVP Ron de Bruin的一个常用function 。 巧合的是，这些链接指向你发布的脚本的确切来源，在这些less数几行之前被修改。

与Range.SpecialCells 。 此方法在一个范围内运行，并只返回符合给定条件的单元格。 就你而言，你似乎只对可见的文本单元感兴趣。 重要的是，它在Range上运行，而不是HTML文本。

为了完整起见，我将在下面发布一个工作版本的脚本。 我当然build议不要理会它，并重温Ron 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