Finding text between font sizes in Word VBA

Question

I'm looking to find text between font sizes in Word VBA. I'm wondering if there's a better way than my code below.

It looks for the minimum font size and then iterates, incrementing by .5 until the maximum. As far as I can tell, there's no way to search for a font size range.

There's a bit of extra matching that you can ignore (it's part of a semantic-less footnote reference matching script)

Dim findResults As Scripting.Dictionary
Set findResults = CreateObject("Scripting.Dictionary")

Set contentRange = ActiveDocument.Content

' Find fonts between range

Dim min
min = 6

Dim max
max = 8

Dim currentFontSize
currentFontSize = min

Do While max >= currentFontSize

    Selection.HomeKey Unit:=wdStory
    Set contentRange = ActiveDocument.Content

    With contentRange.Find.Font
        .Size = currentFontSize
    End With

    With contentRange.Find.Font.Shading
        .ForegroundPatternColor = wdColorAutomatic
    End With

    With contentRange.Find
        .Text = "[0-9]{1,3}"
        .MatchWildcards = True
        .Wrap = wdFindStop
    End With

    contentRange.Find.Execute

    While contentRange.Find.Found
        If contentRange.Font.Position > 2 Then
            Set myRange = ActiveDocument.Range(start:=contentRange.start - 10, End:=contentRange.start + Len(contentRange.Text))
            findResults.Add contentRange.Text, Trim(Replace(myRange.Text, vbCr, ""))
        End If
        'Selection.MoveRight Unit:=wdCharacter, Count:=Len(contentRange.Text)
        contentRange.Collapse wdCollapseEnd
        contentRange.Find.Execute
    Wend

    currentFontSize = currentFontSize + 0.5

Loop

macropod macropod · Accepted Answer · 2019-02-11T07:36:10

My approach would be to find all instances of the text, then test the font size within the loop. That way, you need only do two font size tests - .Font.Size > 5.5 and .Font.Size < 8.5. Try something based on:

Dim FindResults As Scripting.Dictionary, Rng As Range
Set FindResults = CreateObject("Scripting.Dictionary")
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[0-9]{1,3}"
    .Font.Shading.ForegroundPatternColor = wdColorAutomatic
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found = True
    If .Font.Size > 5.5 Then
      If .Font.Size < 9.5 Then
        If .Font.Position > 2 Then
          Set Rng = .Duplicate
          Rng.Start = Rng.Start - 10
          FindResults.Add .Text, Trim(Replace(Rng.Text, vbCr, ""))
        End If
      End If
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With

Finding text between font sizes in Word VBA

1 Answers