vbams-wordword-style

Extract text of elements with given style VBA


I need to extract all text elements with a certain style using a VBA script. I can make it print the line if that style exists within the line, but I need to print only the text matching that style.

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

How can I print only the value of the text tagged with the "Gloss in text" style rather than the entire line?


Solution

  • I figured out how to do this

        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
    

    I wouldn't be surprised if there's a simpler/cleaner way to do this, but I've solved my problem.