Question

我必须发送一封电子邮件，其中包含从过滤器表复制的正文邮件中的表，此代码中过滤器表的名称为“ ds”，并且我使用了RangetoHTML函数（以下代码），但它仅复制了格式，而不是表格的内容如下所示：


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

我希望某些正文可以帮助我将包含全部内容的过滤器表复制到正文电子邮件中。

Answer 1

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

发送带有适当范围的电子邮件，并将其粘贴到VBA Excel中的电子邮件正文中

1 个答案: