ハイライト部分を切り替えるマクロ(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
メソッドは、ThisDocument
のOpen
イベントで実行したいのでPublic
指定。
動作
getHighligetedRangeCaller
メソッドで、ハイライト部分を取得。
んで、toggleHighlightCaller
メソッドでハイライトのオンオフ切り替え。
こいつらをクイック アクセス ツール バーに登録しといて呼び出すと、前にお目にかけたように
こんなふうに動く。
おわりに
今のところ、大量にあるプロパティのほとんどが役に立っていませんが、それは今後の検討課題ということで……。