使用VBA粘贴范围到Outlook不会粘贴任何东西

我试图自动化报告，以便它复制一个范围，将其粘贴到电子邮件的正文中，并发送它。

我使用的是Ron De Bruin给出的确切代码，只是input了我自己的范围和filter声明。

一切工作正常，除了当我收到/显示电子邮件，这只是一个空白的电子邮件给我。 没有粘贴的范围。 我觉得奇怪的是，这工作正常，直到我过滤范围。 当我使用任何types的filter，它打破了，我不知道为什么。

作为参考，这里是我正在使用的确切代码：`

Sub Mail_Selection_Range_Outlook_Body() Dim rng As Range Dim OutApp As Object Dim OutMail As Object ActiveSheet.Range("A1").AutoFilter Field:=6, Criteria1:="<>" ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="Brittany" Set rng = Nothing On Error Resume Next 'Only the visible cells in the selection Set rng = ActiveSheet.Range("A:F").SpecialCells(xlCellTypeVisible) rng.Copy ActiveSheet.Range("U1").Paste 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 = "[e-mail]" .CC = "" .BCC = "" .Subject = "Test for Updates" .HTMLBody = RangetoHTML(rng) .Display 'or use .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) 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

我不使用这个电子邮件，但创build一个任务。 然而，我修改了一下，testing了一下，即使在过滤之后，它也能正常工作。

 Dim olApp As Object Dim olRem As Object Dim myRange As Range Dim olInsp As Object Dim wdDoc As Object Dim oRng As Object Set olApp = CreateObject("Outlook.Application") Set olRem = olApp.CreateItem(0) Set myRange = Selection myRange.Copy Set olInsp = olRem.GetInspector Set wdDoc = olInsp.WordEditor Set oRng = wdDoc.Range With olRem .Subject = "Call " & contact & " - " & company & " - " & city & ", " & state oRng.InsertAfter (oRng.PasteAndFormat(wdFormatOriginalFormatting)) oRng.Collapse wdCollapseEnd oRng.InsertBreak (wdLineBreak) oRng.InsertAfter (Comment) oRng.Collapse wdCollapseEnd oRng.InsertBreak (wdLineBreak) oRng.InsertAfter (oRng.PasteAndFormat(wdFormatOriginalFormatting)) .display End With Set olApp = Nothing Set olRem = Nothing Set olInsp = Nothing Set wdDoc = Nothing Set oRng = Nothing Set myRange = Nothing 

Answer 2

这将粘贴您设置的Col A到Col F的范围，或者您可以稍微修改以粘贴选定的范围，但我不明白filter是如何工作的，所以我已经注释掉了。 我看到filter添加到工作表中的列标题，但整个范围仍粘贴。

码：

 Sub pasteRangeBody() Dim IsCreated As Boolean Dim OutlApp As Object Dim RngCopied As Range ' ActiveSheet.AutoFilterMode = False ' ActiveSheet.Range("A1").AutoFilter Field:=2, Criteria1:="<>" ' ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="Brittany" With ActiveSheet ' Set RngCopied = Selection Set RngCopied = ActiveSheet.Range("A:F").SpecialCells(xlCellTypeVisible) End With On Error Resume Next Set OutlApp = GetObject(, "Outlook.Application") If Err Then Set OutlApp = CreateObject("Outlook.Application") IsCreated = True End If On Error GoTo 0 With OutlApp.CreateItem(0) .Display ' Display email first for signature to be added .Subject = "" .To = "" .CC = "" .HTMLbody = RangetoHTML(RngCopied) & _ "Thank you," & _ .HTMLbody ' Add default signature On Error Resume Next Application.Visible = True If Err Then MsgBox "Unsuccessful", vbExclamation Else End If On Error GoTo 0 End With If IsCreated Then OutlApp.Quit Set OutlApp = Nothing End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 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