如何用vba把excel单元格区域转换为html源代码？

在 如何用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