vba - 提取具有给定样式 VBA 的元素的文本

Question

我需要使用 VBA 脚本提取具有特定样式的所有文本元素。如果该样式存在于该行中，我可以让它打印该行，但我只需要打印与该样式匹配的文本。

Dim singleLine As Paragraph
Dim lineText As String

For Each singleLine In ActiveDocument.Paragraphs
    lineText = singleLine.Range.Text

    'Define the style we're searching for
    Dim blnFound As Boolean
    With singleLine.Range.Find
    .style = "Gloss in Text"

    Do
        'if we find the style "Gloss in Text" in this line
        blnFound = .Execute
        If blnFound Then
            Debug.Print lineText 
            Exit Do
        End If
        Loop
    End With

Next singleLine

如何仅打印带有“文本光泽”样式而不是整行标记的文本的值？

Answer 1

我想出了如何做到这一点

    Sub SearchStyles()
    Dim iCount As Integer, iArrayCount As Integer, bFound As Boolean, prevResult As String

    'store results in an array
    ReDim sArray(iArrayCount) As String
    iArrayCount = 1

    'State your Style type
    sMyStyle = "Gloss in Text"

    'Always start at the top of the document
    Selection.HomeKey Unit:=wdStory

    'Set your search parameters and look for the first instance
    With Selection.Find
        .ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
        .Style = sMyStyle
        .Execute
    End With


    'If we find one then we can set off a loop to keep checking
    Do While Selection.Find.Found = True And Not Selection.Text = prevResult
        iCount = iCount + 1

        'If we have a result then add the text to the array
        If Selection.Find.Found Then
            bFound = True

            'print the selection we found
            Debug.Print Selection.Text
            prevResult = Selection.Text

            'We do a check on the array and resize if necessary (more efficient than resizing every loop)
            If ii Mod iArrayCount = 0 Then ReDim Preserve sArray(UBound(sArray) + iArrayCount)
            sArray(iCount) = Selection.Text

            'Reset the find parameters
            Selection.Find.Execute
        End If
    Loop

    'Finalise the array to the actual size
    ReDim Preserve sArray(iCount)

    Dim xli As Integer
    For xli = 0 To iCount
        Debug.Print sArray(xli)
    Next xli

End Sub

如果有更简单/更清洁的方法可以做到这一点，我不会感到惊讶，但我已经解决了我的问题。