将excel单元格区域转成html源代码作为outlook正文

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
Sub QQ563524869()
Dim oWk As Worksheet
Set oWk = Sheet1
Dim oRng As Range
Set oRng = oWk.Range("A1:D2").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 = "[email protected]"
'抄送人
'.CC = "[email protected]"
'密件抄送人
'.BCC = "[email protected]"
'邮件主题
.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