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

Как я могу напечатать только значение текста маркированного с «Gloss в текстовом» стиле, а не всей линии?

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 

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