在 VBA 中将单词范围转换为带有 HTML 标记的字符串答案

【问题标题】：Convert a Word Range to a String with HTML tags in VBA在 VBA 中将单词范围转换为带有 HTML 标记的字符串
【发布时间】：2020-08-18 22:24:47
【问题描述】：

我有一个 Word 文档，我需要将其中的一些段落复制到 VBA 中的字符串中。这样做时，必须将文本格式转换为 HTML 标记。例如，如果我的段落如下所示：

你好，我是 Alice。

我想得到一个字符串，其中包含：

Hello I am <b>Alice</b>

（如果它也适用于项目符号列表和其他类型的格式，那就太好了）。

我正在使用 Microsoft Visual Basic for Applications 7.0。我是 VBA 新手，我在 Internet 上找到的很多代码对我不起作用，因为我的版本太旧了。不幸的是，就我而言，下载更新的版本不是一种选择。

这是一个代码示例，可以将段落转换为不带格式的字符串：

Dim pParagraph As Paragraph
'... at some point, pParagraph is set to a paragraph of the document

Dim pRange As Range
Dim pString As String
Set pRange = ActiveDocument.Range(Start:=pParagraph.Range.Start, End:=pParagraph.Range.End - 1)
pString = Trim(pRange.Text)

我在 Internet 上进行了一些研究，发现建议将 Range 复制到剪贴板并使用 Clipboard.getText。不幸的是，Clipboard.getText 甚至没有为我编译。

【问题讨论】：

Word 可以将其格式转换为 HTML 标记的唯一方法是使用转换器。一种方法是将文件保存为 HTML，另一种方法是复制到剪贴板。您正在尝试的后者的问题是 VBA 只能从剪贴板获取 text - 它不包含 HTML。 VBA 没有Clipboard.getText，这就是它无法编译的原因。它确实有属于MSForms 库的DataObject。但是，DataObject 只能检索文本，并且不会传递 HTML 或 RTF。
您发现的可能是不属于 Office 或 VBA 的 .NET 代码 - 无论您的版本是新旧版本。在 Word 中保存为 HTML 可能也不会令人满意，因为它不能保存为“简单”的 HTML。您可能需要使用查找/替换来搜索格式并将所需的标签附加到“找到”文本。

标签： vba ms-word

【解决方案1】：

我知道将 Word 中的格式转换为 html 标记的一种方法是使用 Access。如果您创建一个具有长文本数据类型和富文本作为文本格式的字段的 Access 表，并将您的 Word 文本导入其中，当您查询 Access 以将文本放回 Word 时，它会以 html 标记文本的形式出现。

【讨论】：

【解决方案2】：

您可以使用以下代码作为起点。但显然，您必须扩展它以处理您关心的所有标签。

Sub ApplyHTML()
Application.ScreenUpdating = False
With ActiveDocument.Range
  '.ListFormat.ConvertNumbersToText
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = True
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Font.Underline = True
    .Text = ""
    .Replacement.Text = "<u>^&</u>"
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Font.Bold = True
    .Replacement.Text = "<b>^&</b>"
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Font.Italic = True
    .Replacement.Text = "<i>^&</i>"
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Highlight = True
    .Replacement.Text = "<h>^&</h>"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

【讨论】：

【解决方案3】：

只有几个我通常用来在 Outlook 中创建 HTMLBody 的函数。它可能会在未来帮助某人。此过程将按字符检查，因此可能需要一点时间。我在 excel 的预先格式化的单元格中使用它，但也应该在 word 文档上工作。

Function Convert2HTML(myCell As Range) As String
    Dim bldTagOn, itlTagOn, ulnTagOn, colTagOn, phaTagOn As Boolean
    Dim i, chrCount, spaceCount As Integer
    Dim chrCol, chrLastCol, htmlTxt As String
    
    bldTagOn = False
    itlTagOn = False
    ulnTagOn = False
    colTagOn = False
    phaTagOn = False
    chrCol = "NONE"
    htmlTxt = "<div>"
    chrCount = myCell.Characters.Count
    spaceCount = 0
    For i = 1 To chrCount
        With myCell.Characters(i, 1)
        
            If myCell.Characters(i, 4).Text = "    " And Not phaTagOn Then
                htmlTxt = htmlTxt & "<p style='text-indent: 40px'>"
                phaTagOn = True
            Else
                If myCell.Characters(i, 4).Text = "    " And phaTagOn Then
                    htmlTxt = htmlTxt & "</p><p style='text-indent: 40px'>"
                    phaTagOn = True
                End If
            End If
                
            If (.Font.Color) Then
                chrCol = GetCol(.Font.Color)
                If Not colTagOn Then
                    htmlTxt = htmlTxt & "<font color=#" & chrCol & ">"
                    colTagOn = True
                Else
                    If chrCol <> chrLastCol Then htmlTxt = htmlTxt & "</font><font color=#" & chrCol & ">"
                End If
            Else
                chrCol = "NONE"
                If colTagOn Then
                    htmlTxt = htmlTxt & "</font>"
                    colTagOn = False
                End If
            End If
            chrLastCol = chrCol
            
            If .Font.Bold = True Then
                If Not bldTagOn Then
                    htmlTxt = htmlTxt & "<b>"
                    bldTagOn = True
                End If
            Else
                If bldTagOn Then
                    htmlTxt = htmlTxt & "</b>"
                    bldTagOn = False
                End If
            End If
    
            If .Font.Italic = True Then
                If Not itlTagOn Then
                    htmlTxt = htmlTxt & "<i>"
                    itlTagOn = True
                End If
            Else
                If itlTagOn Then
                    htmlTxt = htmlTxt & "</i>"
                    itlTagOn = False
                End If
            End If
    
            If .Font.Underline > 0 Then
                If Not ulnTagOn Then
                    htmlTxt = htmlTxt & "<u>"
                    ulnTagOn = True
                End If
            Else
                If ulnTagOn Then
                    htmlTxt = htmlTxt & "</u>"
                    ulnTagOn = False
                End If
            End If
            
            If (Asc(.Text) = 10) Then
                htmlTxt = htmlTxt & "<br>"
            Else
                htmlTxt = htmlTxt & .Text
            End If
        End With
    Next
    
    If colTagOn Then
        htmlTxt = htmlTxt & "</font>"
        colTagOn = False
    End If
    If bldTagOn Then
        htmlTxt = htmlTxt & "</b>"
        bldTagOn = False
    End If
    If itlTagOn Then
        htmlTxt = htmlTxt & "</i>"
        itlTagOn = False
    End If
    If ulnTagOn Then
        htmlTxt = htmlTxt & "</u>"
        ulnTagOn = False
    End If
    If phaTagOn Then
        htmlTxt = htmlTxt & "</p>"
        phaTagOn = False
    End If
    htmlTxt = htmlTxt & "</div>"
    fnConvert2HTML = htmlTxt
End Function

Function GetCol(strCol As String) As String
    Dim rVal, gVal, bVal As String
    strCol = Right("000000" & Hex(strCol), 6)
    bVal = Left(strCol, 2)
    gVal = Mid(strCol, 3, 2)
    rVal = Right(strCol, 2)
    GetCol = rVal & gVal & bVal
End Function

【讨论】：