在MailBody中发送Excel表格

相关文章推荐

文雅的牛肉面 · c# ...· 1 周前 ·

唠叨的豌豆 · 在JAVA中如何将一个Object转换成Ar ...· 1 周前 ·

没有腹肌的地瓜 · JAVA将Object对象转byte数组 ...· 1 周前 ·

含蓄的作业本 · java object转化为数组 - CSDN文库· 1 周前 ·

坚韧的开心果 · ABAQUS ...· 6 天前 ·

鼻子大的柑橘 · 主进程退出会导致子进程退出吗，请详细说明 ...· 3 月前 ·

低调的菠菜 · curl ...· 5 月前 ·

文质彬彬的拐杖 · Playwright系列（7）：用VSCod ...· 7 月前 ·

面冷心慈的熊猫 · selenium ...· 1 年前 ·

讲道义的砖头 · Conda base环境离线升级 ...· 1 年前 ·

腾讯云

开发者社区

文档意见反馈控制台

首页 TVP

文章/答案/技术大牛

发布

Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
    .To = Range("B1").Value
    .Cc = Range("B2").Value
    .Bcc = Range("B3").Value
    .Subject = Range("B4").Value
    .Body = Range("B5").Value
    .Send
End With
On Error GoTo 0
Set OutMail = Nothing

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

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

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>"
    HtmlContent = HtmlContent & "</tr>"
HtmlContent = HtmlContent & "</table>"

With OutMail
    .HTMLBody = HtmlContent
End With

RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
    .To = "anymail"
    .Cc = ""
    .Bcc = ""
    .Subject = ""
    .HTMLBody = extracttablehtml(thisworkbook.worksheets("whatever"), Range("A1:B5")) '<<<< Here it is
    .Send
End With
On Error GoTo 0
Set OutMail = Nothing

Public Function extracttablehtml(ws As Worksheet, rng As Range) As String
Dim HtmlContent As String, i As Long, j As Long
On Error GoTo 0
HtmlContent = "<table>"
For i = 1 To rng.Rows.Count
    HtmlContent = HtmlContent & "<tr>"
    For j = 1 To rng.Columns.Count
        HtmlContent = HtmlContent & "<td>" & ws.Cells(i, j).Value & "</td>"
    HtmlContent = HtmlContent & "</tr>"
HtmlContent = HtmlContent & "</table>"
extracttablehtml = HtmlContent
Error_Handler_Exit:
    On Error Resume Next
    If Not rng Is Nothing Then Set OutMail = Nothing
    Exit Function
Error_Handler:
    If Alert = True Then
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: single_prop_write_mail_proposal" & vbCrLf & _
               "Error Description: " & Err.Description & _

在MailBody中发送Excel表格

5 个回答