在MailBody中发送Excel表格

相关文章推荐

有胆有识的槟榔 · 如何通过Go SDK ...· 1 月前 ·

阳刚的路灯 · String.raw() - ...· 1 月前 ·

虚心的长颈鹿 · Object.freeze() - ...· 3 周前 ·

腼腆的酱牛肉 · 罗技Lua脚本 ...· 2 月前 ·

爽快的大蒜 · [shell]Linux脚本开头#!/bin ...· 1 年前 ·

朝气蓬勃的饭盒 · 如果iframe ...· 2 年前 ·

虚心的长颈鹿 · 新疆少数民族学生不再为姓名中的“·”烦恼了 ...· 2 年前 ·

开朗的楼梯 · vscode下git blame使用 - 掘金· 2 年前 ·

腾讯云

开发者社区

文档意见反馈控制台

首页 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 个回答