Поиск текста между размерами шрифта в Word VBA - PullRequest
Новая
       7

Поиск текста между размерами шрифта в Word VBA

0 голосов
/ 11 февраля 2019

Я ищу, чтобы найти текст между размерами шрифта в Word VBA.Мне интересно, есть ли лучший способ, чем мой код ниже.

Он ищет минимальный размер шрифта, а затем итерирует, увеличивая на 0,5 до максимального.Насколько я могу судить, нет возможности искать диапазон размеров шрифта.

Есть несколько дополнительных совпадений, которые вы можете игнорировать (это часть сценария сопоставления ссылок на сноски без семантики) 

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

1 Ответ

0 голосов
/ 11 февраля 2019

Мой подход заключается в том, чтобы найти все экземпляры текста, а затем проверить размер шрифта в цикле.Таким образом, вам нужно сделать только два теста размера шрифта - .Font.Size> 5.5 и .Font.Size <8.5.Попробуйте что-нибудь на основе: </p> 

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
...