ハイライト部分を切り替えるマクロ(Word)

ハイライト部分を切り替えるマクロ

コードだけ掲載しておく。

クラスモジュールと標準モジュールを使った。

ハイライト部分を保持するクラス

ハイライト部分を保持し、ハイライト部分の再取得、ハイライトのオンオフ切り替えができるようなオブジェクト。

クラスモジュール HighLightedRanges
Option Explicit

Private parent_ As Document
Private ranges_ As Collection

Public Property Get Parent() As Document
  Set Parent = parent_
End Property

Public Property Get Ranges() As Collection
  Set Ranges = ranges_
End Property

Public Property Get Count() As Long
  Count = ranges_.Count
End Property

Public Property Get Item(ByVal Index As Variant) As Range
  Set Item = ranges_(Index)
End Property

Private Sub Class_Initialize()
  Set parent_ = ThisDocument
  Set ranges_ = New Collection
End Sub

Public Sub getHighLightedRanges()
  On Error GoTo Finalizer
  Application.ScreenUpdating = False
  Dim currentRange As Range
  Set currentRange = Selection.Range
  Call parent_.Range(0, 0).Select
  'ドキュメント内のハイライト部分を取得'
  Dim tmp As Range
  Do
    Set tmp = getNextHighLight(Selection.Range)
    If tmp Is Nothing Then Exit Do
    If Not isValid(tmp) Then Exit Do
    Call ranges_.Add(tmp)
    DoEvents
  Loop
  'テキストボックス内のハイライト部分を取得'
  Set tmp = Nothing
  Dim shp As Word.Shape
  For Each shp In parent_.Shapes
    If shp.Type = msoTextBox Then
      Call shp.TextFrame.TextRange.Select
      Call Selection.Collapse(wdCollapseStart)
      Do
        Set tmp = getNextHighLight(Selection.Range)
        If tmp Is Nothing Then Exit Do
        If Not isValid(tmp) Then Exit Do
        Call ranges_.Add(tmp)
        DoEvents
      Loop
    End If
  Next
  Call currentRange.Select
Finalizer:
  Application.ScreenUpdating = True
End Sub

Private Function isValid( _
    ByVal targetRange As Range) As Boolean
  isValid = False
  With targetRange
    Select Case .Text
      Case "": Exit Function
      Case vbCrLf: Exit Function
      Case vbCr: Exit Function
      Case vbLf: Exit Function
      Case vbNewLine: Exit Function
    End Select
  End With
  isValid = True
End Function

Private Function getNextHighLight( _
             ByVal currentRange As Range) As Range
  Set getNextHighLight = Nothing
  Dim ret As Range
  Set ret = Nothing
  '渡されたRangeオブジェクトにカーソルを置く'
  Call currentRange.Select
  '念のため選択箇所を潰しておく'
  Call Selection.Collapse(wdCollapseStart)
  With Selection.Find
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  'Findオブジェクトの諸設定'
  With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    'これをwdFindStopにしておかないと、検索が終わらない'
    '文書の最後にカーソルがあるときに、先頭から検索してしまう'
    .Wrap = wdFindStop
    .Format = False
    .Highlight = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
  '検索実行'
  Call Selection.Find.Execute
  'ヒットしなければNothingを返す'
  If Not Selection.Find.Found Then Exit Function
  '返り値用変数に検索ヒットしたRangeオブジェクトをセット'
  Set ret = Selection.Range
  '次の検索用に選択範囲を後方に潰す'
  Call Selection.Collapse(Direction:=wdCollapseEnd)
  '返り値をセット'
  Set getNextHighLight = ret
  DoEvents
End Function

Public Sub toggleHighLight()
  If Me.Count = 0 Then Exit Sub
  Dim i As Long
  For i = 1 To Me.Count
    With ranges_(i)
      If .HighlightColorIndex = wdYellow Then
          .HighlightColorIndex = wdNoHighlight
      Else
        .HighlightColorIndex = wdYellow
      End If
    End With
  Next
End Sub

プロパティたくさんと、メソッド二つ。

メソッド呼び出し用コード

標準モジュールに呼び出し用コードを書く。

リスト1
Option Explicit

Private hlRanges As HighLightedRanges

'HighLightedRangesクラスのインポート必須'
Public Sub createInstance()
  Set hlRanges = New HighLightedRanges
  Call hlRanges.getHighLightedRanges
End Sub

Private Sub getHighligetedRangeCaller()
  Dim res As VbMsgBoxResult
  res = MsgBox(Prompt:="ハイライト部分を取得し直します。" & vbCrLf & _
                       "よろしゅうござるか?", _
               Buttons:=vbYesNoCancel, _
               Title:="し、正気でござるか?(´・ω・`)")
  If res <> vbYes Then
    Call MsgBox(Prompt:="やめたでござる。", _
                Title:="なんやねん、それ ( `д´)、ペッ")
    Exit Sub
  End If
  Call createInstance
End Sub

Private Sub toggleHighlightCaller()
  If hlRanges Is Nothing Then Call createInstance
  Call hlRanges.toggleHighLight
End Sub

クイック アクセス ツール バーに登録して呼び出すことを想定しているので、getHighligetedRangeCallerメソッドはPrivate指定。ただし、createInstanceメソッドは、ThisDocumentOpenイベントで実行したいのでPublic指定。

動作

getHighligetedRangeCallerメソッドで、ハイライト部分を取得。

んで、toggleHighlightCallerメソッドでハイライトのオンオフ切り替え。

こいつらをクイック アクセス ツール バーに登録しといて呼び出すと、前にお目にかけたように

f:id:akashi_keirin:20191231221941g:plain

こんなふうに動く。

おわりに

今のところ、大量にあるプロパティのほとんどが役に立っていませんが、それは今後の検討課題ということで……。