我正在尝试自动化报告，以便复制范围，将其粘贴到电子邮件正文中，然后发送。
我正在使用确切的代码Ron De Bruin，只需输入我自己的范围和过滤器声明。
一切正常，除非我收到/显示电子邮件，这只是一封空白的电子邮件给我。它没有粘贴范围。我觉得奇怪的是，这个工作正常，直到我过滤范围。当我对它使用任何类型的过滤器时，它会中断，我不知道为什么。
供参考，以下是我正在使用的确切代码：`
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 = "email@email.com"
.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
`
答案 0 :(得分：0)
我不会将此用于电子邮件，而是用于创建任务。然而，我对它进行了一些修改，对其进行了测试，即使在过滤后也能正常工作。
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
答案 1 :(得分：0)
这会粘贴您将Col A的设定范围粘贴到Col F，或者您可以稍微修改以粘贴所选范围，但我不明白过滤器是如何工作的所以我注释掉了。我看到过滤器已添加到工作表中的列标题中，但仍粘贴了整个范围。
<强>代码：
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