在 如何用vba将excel工作簿、工作表、单元格区域另存为html网页文件? 一文中我们介绍了如何将exce工作簿、工作表、单元格区域另存为html网页文件。
在用vba 发送邮件时,经常需要发送html格式的邮件内容。
如果需要将excel单元格区域带格式的插入到要发送的邮件正文中,需要将其转换为html格式。
以下是一个通用的将excel单元格区域转化为html格式代码的自定义函数:
Function Range2Html(oRng As Range) As String '只读打开文本文档 Const ForReading = 1 '可写打开文本文档 Const ForWriting = 2 '追加打开文本文档,写在原文本文档的末尾 Const ForAppending = 8 '以系统默认的方式打开文本文档 Const TristateUseDefault = -2 '以Unicode方式打开文本文档 Const TristateTrue = -1 '以ASCII方式打开文本文档 Const TristateFalse = 0 Dim oWB As Workbook Set oWB = oRng.Parent.Parent Dim oWk As Worksheet Set oWk = oRng.Parent Dim oPO As PublishObject Dim sPath As String sPath = Excel.ThisWorkbook.Path & "\" Dim sFlie As String sFile = sPath & "Result.htm" With oWB Debug.Print .PublishObjects.Count For Each oPO In .PublishObjects oPO.Delete Next Set oPO = .PublishObjects.Add(SourceType:=xlSourceSheet, Filename:=sFile, Sheet:=oWk.Name, Source:=oRng.Address, HtmlType:=xlHtmlStatic, DivID:="Test1") With oPO '开始发布 .Publish (True) End With End With Set oFSO = CreateObject("Scripting.FileSystemObject") With oFSO Set oTextStream = .OpenTextFile(sFile, ForReading, True, TristateUseDefault) With oTextStream Range2Html = .ReadAll End With End With End Function
然后使用如下的代码发送邮件时将excel单元格区域转成html源代码即可:
Sub QQ1722187970() Dim oWk As Worksheet Set oWk = Sheet12 Dim oRng As Range Set oRng = oWk.Range("B2").CurrentRegion Dim sPath As String sPath = Excel.ThisWorkbook.Path & "\" Dim objOutlookApp As Outlook.Application Set objOutlookApp = New Outlook.Application Dim objAccount As Account '邮件附件对象 Dim objAttachment As Outlook.Attachment With objOutlookApp For Each objAccount In .Session.Accounts If objAccount.AccountType = olPop3 And objAccount.DisplayName Like "工作*" Then '一封邮件对象 Dim objMailItem As Outlook.MailItem Set objMailItem = .CreateItem(olMailItem) With objMailItem '收件人,多个收件人用分号间隔 .To = "1722187970@qq.com" '抄送人 .CC = "1722187970@qq.com" '密件抄送人 .BCC = "1722187970@qq.com" '邮件主题 .Subject = "New Test" '邮件内容格式 .BodyFormat = olFormatRichText '邮件的内容 .HTMLBody = Range2Html(oRng) '要添加的附件 ' .Attachments.Add sPath & "Test.xlsx" objMailItem.SendUsingAccount = objAccount ' 显示对话框 .Display '开始发送邮件 .Send End With End If Next End With End Sub
发表评论