我必须发送一封电子邮件,该邮件的正文中包含一个表,该表是从筛选器表复制而来的。
此代码中过滤器表的名称为“ 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 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 ("[email protected]")
.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