ルビが施された部分のフォント情報を取得する(Word)

WordVBA VBA覚書

ルビが設定された部分のフォント情報を取得する

選択箇所のフォント情報を取得するときには、Selection.Fontオブジェクトにアクセスすればよい。たとえば、

Selection.Font.Name

とすれば、カーソル位置のフォント名が取得できる。

……はずだ。

ルビが設定されている場合の挙動

次の画像をご覧いただきたい。

f:id:akashi_keirin:20200127081511j:plain

「強敵」の直前にカーソルがある。「強敵」の部分は「ＭＳ ゴシック」。その他の部分は「ＭＳ 明朝」である。

このとき、フォント名表示窓の表示は、「ＭＳ 明朝」。

直前の部分のフォント名を表示しているようだ。

次。[Shift]＋[→]で、「強敵」を選択状態にしてみる。

f:id:akashi_keirin:20200127081513j:plain

！

フォント名表示窓が空白に!!!!

この状態で、イミディエイト・ウインドウに

?Selection.Characters(1).Text
?Selection.Font.Name
?Selection.Font.Size

の三つを入力して実行してみると、それぞれ

f:id:akashi_keirin:20200127081516j:plain

f:id:akashi_keirin:20200127081521j:plain

f:id:akashi_keirin:20200127081523j:plain

もう、まったくわけのわからない結果が返る。

次に、[→]ボタンを押して、カーソルを「強敵」の直後に持って行く。

フォント名表示窓の表示は、

f:id:akashi_keirin:20200127081527j:plain

これは、やはり直前の部分のフォント名を表示しているらしい。

ルビが設定されている箇所のフォント情報を取得する

上記の挙動から、ルビの部分が選択されている状態で選択部分のフォント情報を得るには、

  • 一旦カーソルを右に移動する
  • フォント情報を取得する
  • 選択状態に戻す

という操作が必要であると考えた。

ルビが施された親文字のフォント情報を取得する

リスト１
Private Sub getRubiedCharFontInfo()
  Dim currRange As Range  '……(1)'
  Set currRange = Selection.Range
  Call Selection.MoveRight(wdCharacter, 1, wdMove)  '……(2)'
  Debug.Print "フォント名：" & Selection.Font.Name  '……(3)'
  Debug.Print "フォントサイズ：" & Selection.Font.Size
  Call currRange.Select  '……(4)'
End Sub

まず(1)の

Dim currRange As Range
Set currRange = Selection.Range

で、選択範囲をRange型の変数に突っ込んでおく。

んで、(2)の

Call Selection.MoveRight(wdCharacter, 1, wdMove)

でカーソルを1文字分だけ右に移動。これで、ルビを施した文字列の直後にカーソルが来る。

すかさず(3)の

Debug.Print "フォント名：" & Selection.Font.Name
Debug.Print "フォントサイズ：" & Selection.Font.Size

でフォント情報を取得してイミディエイトに表示。

最後に(4)の

Call currRange.Select

で、(1)で保存しておいたRangeオブジェクトを選択する。

実行結果

f:id:akashi_keirin:20200127081532j:plain

イミディエイトの出力はバッチリ。

f:id:akashi_keirin:20200127081529j:plain

ドキュメント（笑）の方も、見かけ上は元どおり。

うむ！

おわりに

ただ、同じ選択範囲に異なるフォントがチャンポンになっていたら詰む……？

衝撃の実行結果(Word)

WordVBA VBA覚書

衝撃の実行結果

最近、WordのVBAでのルビ操作にハマっている。

[Range].PhoneticGuideメソッドでルビを振るのだが、あまり細かい調整ができず、さりとてルビを振った後Field.Code.Textプロパティの値をVBAで書き換えると、

ドキュメントを開きなおしたときにフォント名情報が死ぬ

という結構悲惨なことが起こる。【参考】

仕方なく、上記リンクでも紹介したように、

一旦[Range].PhoneticGuideメソッドでルビを振った後、フィールドコードを表示させて置換する

というしちめんどくさいことをすることになった。

その中で、一つ素朴な疑問が湧いたのである。

素朴な疑問

ルビのフォントの種類を変えるメソッドを作ろうとしたとき、ふと

これ、存在しないフォント名を指定したらどないなるんやろ？

と思ったのだ。

で、やってみた。

f:id:akashi_keirin:20200125205424j:plain

このように、ドキュメント（笑）の「わ」の部分（ＭＳ 明朝）を選択した状態で、次のコードを実行するのである。

リスト１
Private Sub testInvalidFontName()
  Selection.Font.Name = "ち～んｗ"
End Sub

見ての通り、選択部分のフォント名に「ち～んｗ」というふざけた名前を指定してみるのである。

結果、どうなるか。

f:id:akashi_keirin:20200125205427j:plain

なんと、こうなるのである。

エラーが出るわけではないのである。

おわりに

これは困ったことではなかろうか。

おかしなフォント名が引数で指定されても防ぎようがないではないか。

……というわけで、当面、〈ルビのフォント名を指定するメソッド〉については、使用できるフォントを制限する方向で実装することにします。

しっかし、「フォント名：ち～んｗ」ってなんやねんな。

マクロでルビ振りをするときの注意(Word)

WordVBA VBA覚書

マクロでルビ振りをするときの注意(Word)

Word VBA のバグを発見したので、ここで盛大に晒しますｗ

[Range].PhoneticGuideメソッドでルビを振る

まず、次のようなドキュメント（笑）を用意する。

f:id:akashi_keirin:20200124074659j:plain

選択部分を見たらわかるように、フォントは「ＭＳ 明朝」。

んで、こいつに、次のリスト１を実行する。

リスト１
Private Sub TestPhoneticGuide()
  Const MS_P_MINGZHAO As String = "ＭＳ Ｐ明朝"
  Call Selection.Range.PhoneticGuide( _
                         Text:="とも", _
                         Alignment:=wdPhoneticGuideAlignmentOneTwoOne, _
                         Raise:=10, _
                         FontSize:=5, _
                         FontName:=MS_P_MINGZHAO)
End Sub

[Range].PhoneticGuideメソッドを用いて、「強敵」という親文字に、5ポイントのＭＳ Ｐ明朝で「とも」とルビを振るコード。

f:id:akashi_keirin:20200124074734g:plain

こうなる。

で、「強敵」の部分を調べると、

f:id:akashi_keirin:20200124074702j:plain

このように、ちゃんと5ポイントのＭＳ Ｐ明朝で「とも」とルビが振られていることがわかる。

ここで、一旦ドキュメント（笑）を閉じ、開き直す。

もう一度、「強敵」の部分を調べる。

f:id:akashi_keirin:20200124074704j:plain

何も変わっていない。当り前だけど。

ここで、フィールドコードを調べる。

f:id:akashi_keirin:20200124074707j:plain

EQ \* jc2 \* "Font:ＭＳ Ｐ明朝" \* hps10 \o\ad(\s\up 10(とも),強敵)

こうなっている。

「hps10」の部分がルビのフォントサイズを表す。実際のサイズ（5ポイント）の2倍の数値が記録されている。

マクロでルビのフォントサイズを変更する

このフィールドコードをマクロで書き換えてみる。

リスト２
Private Sub testReplaceFieldCode()
  Dim tgtField As Field
  With Selection.Fields(1)
    .Code.Text = Replace(.Code.Text, "hps10", "hps9")
  End With
End Sub

選択範囲のField.Codeプロパティの返り値（Rangeオブジェクト）のTextプロパティがフィールドコード文字列を表すので、その「hps10」を「hps9」に置換してやれば、フォントサイズは4.5ポイントに変わる。

リスト２を実行した後、「強敵」の部分を調べると、

f:id:akashi_keirin:20200124074710j:plain

ちゃんとフォントサイズが4.5ポイントになっている。

f:id:akashi_keirin:20200124074713j:plain

フィールドコードはこのとおり。ちゃんと「hps9」になっているのがわかる。

ドキュメント（笑）を開き直す

さて、先ほどのドキュメント（笑）を一旦閉じて開き直すと、どうなるか。

f:id:akashi_keirin:20200124074716j:plain

おわかりだろうか。

なんと、ルビのフォントが親文字と同じ「ＭＳ 明朝」に化けてしまうのである。

これは、結構深刻な問題ではなかろうか。

回避策

ちなみに、フォントサイズだけではなく、フォントの種類など、とにかくマクロでフィールドコードを書き換えると、同様のことが起こる。

今回は、親文字がＭＳ 明朝、ルビがＭＳ Ｐ明朝という非常に違いのわかりづらい（笑）例だったが、ゴシック系の親文字に明朝系のルビ、みたいなときは非常に困る。

今のところ回避策としては、

  • [Range].PhoneticGuideでルビを振る
  • [Alt]+[F9]でフィールドコードを表示する
  • [Ctrl]+[H]で置換ダイアログを表示する
  • 関係するフィールドコード文字列を置換する

ぐらいしか思いつかない。

今回の例だと、

[Alt]+[F9]でフィールドコードを表示し、

f:id:akashi_keirin:20200124074719j:plain

[Ctrl]+[H]で置換ダイアログの「検索する文字列」に「hps10」、「置換する文字列」に「hps9」を入力して[置換]ボタンをクリック。

f:id:akashi_keirin:20200124074724j:plain

完了。

「強敵」のところを調べると、

f:id:akashi_keirin:20200124074727j:plain

このとおり。

今度は、一旦閉じて開き直しても、

f:id:akashi_keirin:20200124074730j:plain

大丈夫。

おわりに

わけのわからんことが起こるなあ。

Selection.MoveRightメソッド(Word)の挙動に注意

WordVBA VBA覚書

［Selection］.MoveRightメソッドの挙動に注意

[Selection].MoveRightメソッド（[Selection].MoveLeftメソッド）を使用していて軽くハマったので、記しておく。

[Selection].MoveRightメソッド

[Selection].MoveRightメソッドというのは、Wordでドキュメント上のカーソルを動かすメソッド。

akashi-keirin.hatenablog.com

このときにも触れたことがある。

文字通りカーソルを右に動かすメソッド。

簡単におさらいをしておくと、使うときは

Call [Selection].MoveRight([Unit], [Count], [Extend])

と書く。

で、

  • 引数Unitで移動の単位
  • 引数Countで移動の量
  • 引数Extendで移動の仕方（単純にカーソルを動かすか、ドラッグしたように動かすか）

をそれぞれ指定する。

たとえば、

Selection.MoveRight(wdCharacter, 1, wdExtend)

と書けば、

  • 文字単位で
  • 1だけ
  • ドラッグしたように

カーソルを右に動かすことになる。

通常の挙動

たとえば、

f:id:akashi_keirin:20200122074421j:plain

このようなドキュメント（笑）上で、「強敵」の直前にカーソルを置いて、次のリスト１を実行するとどうなるか。

リスト１
Private Sub moveCursorTest()
  Call Selection.MoveRight(wdCharacter, 1, wdExtend)
End Sub

当然、

f:id:akashi_keirin:20200122074426g:plain

こうなる。

何の不思議もない。疑問などあろうはずがありません。

文字にルビが振られているとき

では、文字にルビが振られているとどうなるか。

今度は、先ほどのドキュメント（笑）を、

f:id:akashi_keirin:20200122074423j:plain

このように変更する。「強敵」の２文字に「とも」とルビを振った。

この状態で、「強敵」の直前にカーソルを置いて、リストを実行してみる。

すると、

f:id:akashi_keirin:20200122074440g:plain

なんと、こうなるのである！

おわりに

キーボード操作と全く同じ結果になるとはいえ、少し注意が必要かも知れない。

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

VBA自作クラス VBA自作メソッド WordVBA

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

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

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

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

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

クラスモジュール 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

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

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

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

リスト１
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メソッドでハイライトのオンオフ切り替え。

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

f:id:akashi_keirin:20191231221941g:plain

こんなふうに動く。

おわりに

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

ズンドコ節で遊ぶ

VBA自作クラス VBA自作メソッド

ズンドコ節で遊ぶ

ノンプロ研のSlackのチャンネルに「今週のお題」というやつがある。毎週一つ、ちょっとした「お題」（〈数字をローマ数字に変換する関数を作れ〉とかそういうやつ）がランダムに出される。

今回、

「ズン」と「ドコ」をランダムで出力し、「ズンズンズンズンドコ」という並びが完成したら「キ・ヨ・シ！」と出力するプログラムを書け

という「お題」が出された。

GASやPythonで回答している人はいたものの、VBAで回答した人はいなかったので、ちょっとやってみた。

「ズン」と「ドコ」をランダムで出力する

これは、単純にRnd関数を使えばよいと考えた。

Rnd関数は「0～1未満の数」をランダムに生成するらしいので、

Int(2 * Rnd)

で0か1かをランダムに取得することができる。

リスト１
Private Function genLyric() As String
  Dim ret As String
  ret = "ズン"
  Randomize
  Dim tmp As Long
  tmp = Int(2 * Rnd)
  If tmp = 1 Then ret = "ドコ"
  genLyric = ret
End Function

このgenLyricメソッドを呼べば、「ズン」か「ドコ」か、いづれかの文字列を取得することができる。

ズンドコ節を歌うクラスを作る

リスト１を用いれば、「ズン」か「ドコ」かのどちらかを歌わせることができる。

後は、歌い続ける中で「ズンズンズンズンドコ」の並びが完成したら「キ・ヨ・シ！」と歌わせるようにすればよい。

これは、要素数5のQueueではないか！

ならば、クラスの内部に要素数5のQueueを持たせて、歌うたびにそれをチェックすればよいではないか！

リスト２　クラスモジュール Zundoko
'### オブジェクト名は Zundoko ###'
Option Explicit

'Field Variables'    '……(1)'
Private zundoko1 As String
Private zundoko2 As String
Private zundoko3 As String
Private zundoko4 As String
Private zundoko5 As String

Private hasDone_ As Boolean

'Properties'    '……(2)'
Public Property Get HasDone() As Boolean
  HasDone = hasDone_
End Property

Public Property Get Lyrics() As String
  Dim ret As String
  ret = zundoko1
  ret = ret & zundoko2
  ret = ret & zundoko3
  ret = ret & zundoko4
  ret = ret & zundoko5
  Lyrics = ret
End Property

'Constructor'
Private Sub Class_Initialize()    '……(3)'
  hasDone_ = False
  Dim n As Long
  n = 0
  Do Until n = 5
    Call Me.sing
    n = n + 1
  Loop
End Sub

'Methods'
Public Sub sing()    '……(4)'
  Dim tmp As String    '……(5)'
  tmp = genLyric
  zundoko1 = zundoko2    '……(6)'
  zundoko2 = zundoko3
  zundoko3 = zundoko4
  zundoko4 = zundoko5
  zundoko5 = tmp
  Debug.Print tmp    '……(7)'
  If Me.Lyrics = "ズンズンズンズンドコ" Then  '……(8)'
    hasDone_ = True
    Debug.Print "キ・ヨ・シ！"
  End If
End Sub

Public Sub resetZundoko()    '……(9)'
  hasDone_ = False
End Sub

'Internal Methods'
'リリック（笑）生成用メソッド'
Private Function genLyric() As String
  Dim ret As String
  ret = "ズン"
  Randomize
  Dim tmp As Long
  tmp = Int(2 * Rnd)
  If tmp = 1 Then ret = "ドコ"
  genLyric = ret
End Function

相変わらずのタテ長。

(1)の

Private zundoko1 As String
Private zundoko2 As String
Private zundoko3 As String
Private zundoko4 As String
Private zundoko5 As String

Private hasDone_ As Boolean

はフィールド変数。

上の五つは直近五つのリリック（笑）を蓄えておく場所。

最後の一つ（hasDone_）は、ズンドコ節が完成したかどうかを表すフラグ。「ズン、ズン、ズン、ズンドコ　キ・ヨ・シ！」が完成したらTrueになる。

(2)の

Public Property Get HasDone() As Boolean
  HasDone = hasDone_
End Property

Public Property Get Lyrics() As String
  Dim ret As String
  ret = zundoko1
  ret = ret & zundoko2
  ret = ret & zundoko3
  ret = ret & zundoko4
  ret = ret & zundoko5
  Lyrics = ret
End Property

はプロパティ。プロパティは二つ。

HasDone

はズンドコ節が完成したかどうかをこのクラスの利用者に知らせるもの。

もう一つのLyricsプロパティは、直近五つのリリック（笑）をつなぎ合わせた文字列を返す。

(3)の

Private Sub Class_Initialize()
  hasDone_ = False
  Dim n As Long
  n = 0
  Do Until n = 5
    Call Me.sing
    n = n + 1
  Loop
End Sub

はコンストラクタ。

hasDone_を明示的にFalseにする他、この段階で五つのリリック（笑）を満たしておく。

リリック（笑）を取得するためのsingメソッドについては後述。

(4)の

Public Sub sing()
  Dim tmp As String    '……(5)'
  tmp = genLyric
  zundoko1 = zundoko2    '……(6)'
  zundoko2 = zundoko3
  zundoko3 = zundoko4
  zundoko4 = zundoko5
  zundoko5 = tmp
  Debug.Print tmp    '……(7)'
  If Me.Lyrics = "ズンズンズンズンドコ" Then  '……(8)'
    hasDone_ = True
    Debug.Print "キ・ヨ・シ！"
  End If
End Sub

がリリック（笑）を取得して歌うsingメソッド。

まず(5)の

Dim tmp As String
tmp = genLyric

で変数tmpを用意。

リスト１のgenLyricで「ズン」か「ドコ」かを取得して変数tmpに突っ込む。

次に(6)の

zundoko1 = zundoko2
zundoko2 = zundoko3
zundoko3 = zundoko4
zundoko4 = zundoko5
zundoko5 = tmp

で、変数zundoko2～同5に入っている文字列をそれぞれzundoko1～同4にずらして入れる。

最後にzundoko5に先ほど取得したtmpを突っ込む。

これで、あたかも要素数五つのQueueに新たに一つの要素を追加（して先頭の要素を消去）したかのような動作になる。

ここで(7)の

Debug.Print tmp

で新たに取得したリリック（笑）をイミディエイトに出力。

そうして今度は(8)の

If Me.Lyrics = "ズンズンズンズンドコ" Then
  hasDone_ = True
  Debug.Print "キ・ヨ・シ！"
End If

で直近五つのリリック（笑）を調べる。

直近五つのリリック（笑）、すなわちLyricsプロパティの値がズンズンズンズンドコになっていたら条件成立なので、

hasDone_ = True
Debug.Print "キ・ヨ・シ！"

を実行。

hasDone_をTrueにし、イミディエイトに「キ・ヨ・シ！」を出力する。

「ズン」とか「ドコ」は１行づつイミディエイトに表示されるので、条件が成立した場合は、イミディエイトに

ズン
ズン
ズン
ズン
ドコ
キ・ヨ・シ！

と表示されることになる。

最後の「ズン」と「ドコ」はⅠ行で表示した方が雰囲気は出るんですけどね……。

最後、(9)の

Public Sub resetZundoko()    '……(9)'
  hasDone_ = False
End Sub

は、HasDoneプロパティをFalseにするためのもの。ただそれだけ。

使ってみる

次のコードで実験。

リスト３
Private Sub testZundoko()
  Dim zd As Zundoko
  Set zd = New Zundoko
  Dim n As Long
  n = 1
  Do Until zd.HasDone
    Call zd.sing
    n = n + 1
    If n > 100 Then
      Debug.Print "タイムオーバー！　残念！"
      Exit Sub
    End If
    DoEvents
  Loop
  Debug.Print n & " 回で達成！"
End Sub

見ての通り、条件が成立するまでsingメソッドを実行し続ける。

最後に何回目で「ズンズンズンズンドコキ・ヨ・シ！」が完成したかを表示するようにした。なお、「ズンズンズンズンドコ」が完成しない限り、延々singメソッドを実行し続けるので、100回で一旦やめるようにした。

実行すると、

f:id:akashi_keirin:20200103150930g:plain

こんな感じ。

おわりに

頭の体操です。

もっとスマートなやり方がありそうですね。

Find.Executeメソッドのハマりを回避する(Word)

VBA覚書 VBA自作メソッド

Find.Executeメソッドのハマりを回避する(Word)

前回

akashi-keirin.hatenablog.com

お知らせしたように、Selection.Collapseメソッドが（仕方がないにせよ）カーソルが末尾にあるときに悲しい挙動をしてしまうせいで、Find.ExecuteメソッドをDo ～ Loopで回そうとすると、ハマってしまうことがある。（いつもいつもハマるわけでもないのが謎。かつてハマらなかったやつが急にハマり出したりする。原因は未解明。ハマると結構な大事になるので、注意が必要。）

で、回避策を考えた。

[Range].Textプロパティの値で判定する

これまで、私が経験したハマりのときの[Range].Textプロパティの値は、""（空文字）とvbCrだった。

この経験をもとに、次のようなメソッドを作成した。

リスト１
Private Function isValid( _
    ByVal targetRange As Range) As Boolean
  isValid = False
  Select Case targetRange.Text
    Case "": Exit Function    '……(1)'
    Case vbCrLf: Exit Function
    Case vbCr: Exit Function    '……(2)'
    Case vbLf: Exit Function
    Case vbNewLine: Exit Function
  End Select
  isValid = True
End Function

これまで経験したのは(1)と(2)のパターンだけだったのだが、念のため似たようなものを全部追加しておく。

前々回

akashi-keirin.hatenablog.com

紹介したgetNextHighLightメソッドの返り値（検索でヒットしたRangeオブジェクト）をこのisValidメソッドに渡せば、ハマりパターンになるときにFalseが返るので、ループから抜けたらよい、という考え方。

たとえば、

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 someCollection.Add(tmp)
Loop

みたいにすれば、検索でヒットしたハイライト部分（Rangeオブジェクト）を次々にCollectionに追加していくことができる。

末尾の改段落記号を取得してしまったときは、isValidメソッドがFalseを返すので、Exitしてくれる。つまり、ハマらずに済むということだ。

おわりに

ハイライト部分をCollectionに突っ込む、という考え方を生かして、ハイライト部分を取得するツール、取得したハイライト部分をオン／オフするツールを作って、クイック アクセス ツール バーに登録してみました。

f:id:akashi_keirin:20191231221941g:plain

これがその動作シーンです。

結構便利です。