Извлечь текст элементов с заданным стилем 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

Я не удивлюсь, если есть более простой / чистый способ сделать это, но я решил свою проблему.