问在MailBody中发送Excel表格

EN

Dim rng As Range, cell As Range, HtmlContent As String, i As Long, j As Long
Set rng = Range("B5:D10")
HtmlContent = "<table>"

For i = 5 To rng.Rows.Count + 4
    HtmlContent = HtmlContent & "<tr>"
    For j = 2 To rng.Columns.Count + 2
        HtmlContent = HtmlContent & "<td>" & Cells(i, j).Value & "</td>"
    Next
    HtmlContent = HtmlContent & "</tr>"
Next
HtmlContent = HtmlContent & "</table>"

With OutMail
    '...
    .HTMLBody = HtmlContent
    '...
End With

Sub test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = Sheets("Sheet1").Range("B5:D10").SpecialCells(xlCellTypeVisible)
On Error Resume Next
With OutMail
    .To = Range("B1").Value
    .Cc = Range("B2").Value
    .Bcc = Range("B3").Value
    .Subject = Range("B4").Value
    .HTMLBody = RangetoHTML(rng)
    .Display
End With
On Error GoTo 0
Set OutMail = 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"
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
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 SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Public Sub Email()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim FSObj As Scripting.FileSystemObject
Dim TStream As Scripting.TextStream
Dim rngeSend As Range
Dim strHTMLBody As String


'Select the range to be sent
Set rngeSend = Application.Range("B1:G35")
If rngeSend Is Nothing Then Exit Sub    'User pressed Cancel
On Error GoTo 0

'Now create the HTML file
ActiveWorkbook.PublishObjects.Add(xlSourceRange, "C:\sales\tempsht.htm", rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True


'Create an instance of Outlook (or use existing instance if it already exists
Set olApp = CreateObject("Outlook.Application")

'Create a mail item
Set olMail = olApp.CreateItem(olMailItem)

'Open the HTML file using the FilesystemObject into a TextStream object
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile("C:\sales\tempsht.htm", ForReading)

'Now set the HTMLBody property of the message to the text contained in the TextStream object
strHTMLBody = TStream.ReadAll

olMail.HTMLBody = strHTMLBody
olMail.To = "anybody@anywhere.com"
olMail.Subject = "Email Subject"
olMail.Send