使用Excel VBA将筛选范围粘贴到电子邮件正文中发送电子邮件

我必须发送一封电子邮件，邮件正文中包含一个从过滤表复制的表

在此代码中，筛选器表的名称为“ds”

我使用函数RangetoHTML（下面的代码），但它只复制格式，不复制表的内容：

Sub Email_Syndicate()

Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Dim cell As Range
Dim Signature As String
Dim ds As Range

Set rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
For Each cell In rng
rw = cell.Row
If cell.Value <> "" Then
EmailSendTo = cell.Value
Nme = cell.Offset(0, 3).SpecialCells(xlCellTypeVisible)
xCC = cell.Offset(0, 1)
att = cell.Offset(0, 4).Value
EmailSubject = cell.Offset(0, 2)
lr1 = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
Sheet3.Range("A1:N" & lr1).AutoFilter field:=6, Criteria1:=Sheet4.Range("F2").Value
    lr = Sheet3.Cells(Sheet3.Rows.Count, 1).End(xlUp).Row
    Set ds = Sheet3.Range("A1:N" & lr).SpecialCells(xlCellTypeVisible)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Display
End With
Signature = OutMail.HTMLBody
'On Error Resume Next
With OutMail
.Subject = EmailSubject
.To = EmailSendTo
.CC = xCC
'.Body = MailBody
.HTMLBody = RangetoHTML(ds) 
.Display
.send
End With

Set OutMail = Nothing
Set OutApp = Nothing
MailBody = ""
End If
With Application
    .EnableEvents = 1
    .Calculation = xlCalculationAutomatic
End With
    Set OutMail = Nothing: Set OutApp = Nothing

Next
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object, ts As Object, TempWB As Workbook, TempFile As String

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

    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=xlPasteAll
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteColumnWidths, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    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
    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=")

    TempWB.Close 0
    Kill TempFile

    Set ts = Nothing: Set fso = Nothing: Set TempWB = Nothing

End Function 

Sub-Email\u辛迪加（）
Dim OutApp作为对象
将邮件变暗为对象
将主题设置为字符串
将EmailSendTo设置为字符串
将邮件正文设置为字符串
暗淡单元格作为范围
作为字符串的数字签名
变暗ds作为范围
设置rng=范围（范围（“B2”）、范围（“B”和行数）。结束（xlUp））
对于rng中的每个单元
rw=单元格。行
如果单元格的.Value为“”，则
EmailSendTo=cell.Value
Nme=单元偏移量（0,3）.特殊单元（xlCellTypeVisible）
xCC=单元偏移量（0，1）
att=单元偏移量（0,4）.值
EmailSubject=单元格偏移量（0,2）
lr1=Sheet3.单元格（Rows.Count，1）.结束（xlUp）.行
Sheet3.范围（“A1:N”和lr1）.自动筛选字段：=6，准则1:=Sheet4.范围（“F2”）.值
lr=Sheet3.单元格（Sheet3.Rows.Count，1）.结束（xlUp）.行
设置ds=Sheet3.范围（“A1:N”和lr）.特殊单元格（xlCellTypeVisible）
Set-OutApp=CreateObject（“Outlook.Application”）
Set OutMail=OutApp.CreateItem（o）
发邮件
.展示
以
签名=OutMail.HTMLBody
'出现错误时，请继续下一步
发邮件
.Subject=电子邮件主题
.To=电子邮件发送至
.CC=xCC
'.Body=MailBody
.HTMLBody=RangetoHTML（ds）
.展示
.发送
以
发送邮件=无
设置应用程序=无
MailBody=“”
如果结束
应用
.EnableEvents=1
.Calculation=xlcalculation自动
以
Set-OutMail=Nothing:Set-OutApp=Nothing
下一个
端接头
函数RangetoHTML（rng作为范围）
Dim fso作为对象，ts作为对象，TempWB作为工作簿，TempFile作为字符串
TempFile=Environ$（“temp”）和“\”格式（现在是“dd-mm-yy h-mm-ss”）和“.htm”
收到
Set TempWB=工作簿。添加（1）
带临时工作表（1）
.单元格（1）.粘贴特殊粘贴：=xlPasteAll
.单元格（1）.粘贴特殊值，False，False
.单元格（1）.粘贴特殊XLPasteColumnWidth，False，False
.单元格（1）.粘贴特殊xlPasteFormats，False，False
.单元格（1）。选择
Application.CutCopyMode=False
以
使用TempWB.PublishObjects.Add（_
SourceType:=xlSourceRange_
文件名：=临时文件_
工作表：=临时工作表（1）.名称_
来源：=TempWB.Sheets（1）.UsedRange.Address_
HtmlType:=xlHtmlStatic）
.发布（真实）
以
设置fso=CreateObject（“Scripting.FileSystemObject”）
设置ts=fso.GetFile（TempFile）.OpenAsTextStream（1，-2）
RangetoHTML=ts.readall
关闭
RangetoHTML=Replace（RangetoHTML，“align=center x:publishsource=”_
“align=left x:publishsource=”）
TempWB.Close 0
杀死临时文件
设置ts=Nothing:设置fso=Nothing:设置TempWB=Nothing
端函数

如何将包含完整内容的筛选表复制到电子邮件正文

Sub SendEmail_1() 

Dim outlook As Object
Dim newEmail As Object
Dim xInp As Object
Dim pgEdit As Object
Dim pos As Integer

Set outlook = CreateObject("Outlook.Application")
Set newEmail= outlook.Createitem(o)

'construction email
With newEmail
        .Recipients.Add ("person@email.com") 
        .Subject = "Subject goes here"
        Set xInp = newEmail.GetInspector 'gets you into the test editor
        Set pgEdit = xInp.WordEditor 'returns a word document object you can edit
        'selects data we want to copy into email
        Sheets("your Sheet").Range("your Range").Copy
        'pastes the excel range over the indicator
        pgEdit.Range(Start:=0, End:=1).PasteSpecial Placement:=wdInLine
        Application.CutCopyMode = True
        .display
        .send
        End With
End Sub