Sub MyPhoneticGuide()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 漢字ルビ逐次入力処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Word VBA
  Rem 機能：文書内の漢字を総て検索し、順次に各々の漢字にルビを入力する。
  Rem 注記…
  Rem   1. Unicode（16進）による漢字の文字コードは、規格が変更される可能性あり。
  Rem      ツールバーの[挿入]から[記号と特殊文字...]を選び、漢字のUnicode（16進）を確認すること。
  Rem   2. 文書内の既存のフィールドを読み飛ばす処理の条件は、将来の保証なし。
  Rem   3. 選択範囲を指定すると、指定した範囲の漢字を検索する。
  Rem      範囲を指定しなかった場合は、カーソルから文書の末尾までを検索する。
  Rem 履歴…
  Rem   第1版：2004/11/01：作成。
  Rem   第2版：2007/06/28：自動ルビ入力／ルビ手入力の選択を追加。
  Rem   第3版：2007/07/08：範囲指定ができるようにした。件数表示を追加。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim MyKanji As String
  Dim i As Long
  Dim c As Long
  '
  Rem 参照設定する場合：Microsoft VBScript Regular Expressions 5.5
  Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
  Dim myMatches As Variant ' MatchCollection
  Dim myMatch As Variant ' Match
  Dim myPttn As String
  '
  Dim myTimeOut As Variant
  Dim myRange As Word.Range
  Dim myStartMarker As Word.Range
  Dim myMoveRightCount As Long
  Dim myStatusBar As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyPhoneticGuide"
  '
  If Selection.Range.Text = "" Then
    Rem カーソルが単語の途中にあると、不都合が起こるので、
    Rem 単語の先頭に移動する。
    Selection.Words.Item(1).Select
    Selection.Collapse wdCollapseStart
    Selection.MoveEnd Unit:=wdStory, Count:=1
  End If
  '
  Set myRange = Selection.Range
  Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyPhoneticGuideSubEntry:
  Call MyPhoneticGuideCmmdBar(myTitle)
  '
  Select Case CommandBars(myTitle).Controls(1).FaceId
    Case 193
      myTimeOut = 1
    Case 189
      myTimeOut = 0
    Case 330
      GoTo MyPhoneticGuideSubExit
  End Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem Unicode（16進）による漢字の文字コードの範囲を指定する。
  MyKanji = ChrW(Val("&h4E00")) & "-" & ChrW(Val("&h7FFF"))
  MyKanji = MyKanji & ChrW(Val("&h8000")) & "-" & ChrW(Val("&h9FA5"))
  MyKanji = MyKanji & ChrW(Val("&hF929")) & "-" & ChrW(Val("&hFA2D"))
  MyKanji = "[" & MyKanji & "]"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myRange.Select
  With myRegExp
    .Pattern = MyKanji & "+" ' パターンを設定
    .IgnoreCase = False ' 大文字と小文字を区別する
    .Global = True ' 文字列全体を検索
  End With
  Set myMatches = myRegExp.Execute(myRange.Text)
  '
  Rem 検索開始点の取得。
  Selection.Collapse wdCollapseStart
  Set myStartMarker = Selection.Range
  '
  Rem 文字列検索を実行する。
  With Selection.Find
    For i = 0 To myMatches.Count - 1
      .ClearFormatting
      .Text = myMatches.Item(i).Value
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchFuzzy = False
      .MatchWildcards = False
      .Execute
      '
      c = (i + 1) * 100 \ myMatches.Count
      myStatusBar = Format(c, "##0") & "%  "
      myStatusBar = myStatusBar & (i + 1) & "/" & myMatches.Count & "件"
      Application.StatusBar = myTitle & "：処理中" & " " & myStatusBar
      '
      If AscW(Selection.Range.Words.Item(1).Text) = 21 Then
        Rem 検索した文字列の範囲がフィールドの場合、ルビの入力をすると、
        Rem Microsoft Wordが異常終了するため、これを避けるための苦肉の策。
        Rem フィールドを読み飛ばし、次の文字列を検索する。
        Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdMove
      Else
        Rem 検索で選択した文字列の開始点を取得する。
        Set myStartMarker = Selection.Range
        Rem [ルビ]ダイアログボックスの[対象文字列]の件数を取得する。
        myMoveRightCount = Selection.Range.Words.Count
        Rem [ルビ]ダイアログボックスを表示する。
        On Error Resume Next
        If Dialogs(wdDialogPhoneticGuide).Show(myTimeOut) = -1 Then
          Rem [キャンセル]ボタンを押した場合、処理を終了する。
          Selection.Collapse wdCollapseStart
          Exit For
        End If
        Rem [OK]ボタンを押すと、なぜかカーソルが文書の先頭に行くため、
        Rem 検索で選択した文字列の開始点に戻る。苦肉の策。
        myStartMarker.Select
        Rem 検索で選択した文字列の終了点に移る。
        Rem [ルビ]ダイアログボックスで、[対象文字列]が複数あった場合にも対応する。苦肉の策。
        Selection.MoveRight Unit:=wdCharacter, Count:=myMoveRightCount
      End If
      '
      DoEvents
    Next ' i
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyPhoneticGuideSubExit:
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
End Sub ' MyPhoneticGuide *----*----*    *----*----*    *----*----*    *----*----*

Sub MyPhoneticGuideCmmdBar(myTitle As String)
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttn As CommandBarControl
  Dim myCtrlBttnAuto As CommandBarControl
  Dim myCtrlBttnManu As CommandBarControl
  Dim myCtrlBttnCancel As CommandBarControl
  '
  Dim myFaceId As Long
  Dim myMsg As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True)
  Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrlBttnAuto = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
  Set myCtrlBttnManu = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  '
  myMsg = myTitle & vbCrLf & vbCrLf
  myMsg = myMsg & "漢字ルビ逐次入力処理" & vbCrLf & vbCrLf
  '
  With myCtrlBttn
    .DescriptionText = "漢字ルビ逐次入力処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を選択して下さい。"
    .TooltipText = "下記の処理を一つ選択して下さい。"
    .FaceId = 1089
    myFaceId = .FaceId
  End With
  '
  With myCtrlBttnAuto
    .DescriptionText = "[自動ルビ入力]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "自動ルビ入力"
    .TooltipText = "自動的に漢字にルビを入力します。"
    .FaceId = 193
    .OnAction = myTitle & "BttnAuto"
  End With
  '
  With myCtrlBttnManu
    .DescriptionText = "[ルビ手入力]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "ルビ手入力"
    .TooltipText = "手作業で漢字にルビを入力します。"
    .FaceId = 189
    .OnAction = myTitle & "BttnManu"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & Space(20)
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = myTitle & "BttnCancel"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Beep
  Do
    On Error Resume Next
    myCmmdBar.ShowPopup
    On Error GoTo 0
    DoEvents
    If myCmmdBar.Controls(1).FaceId <> myFaceId Then Exit Do
  Loop
End Sub ' MyPhoneticGuideCmmdBar *----*----*    *----*----*    *----*----*    *----*----*

Sub MyPhoneticGuideBttnAuto(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[自動ルビ入力]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyPhoneticGuide").Controls(1).FaceId = 193
End Sub ' MyPhoneticGuideBttnAuto *----*----*    *----*----*    *----*----*    *----*----*

Sub MyPhoneticGuideBttnManu(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[ルビ手入力]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyPhoneticGuide").Controls(1).FaceId = 189
End Sub ' MyPhoneticGuideBttnManu *----*----*    *----*----*    *----*----*    *----*----*

Sub MyPhoneticGuideBttnCancel(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[キャンセル]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyPhoneticGuide").Controls(1).FaceId = 330
End Sub ' MyPhoneticGuideBttnCancel *----*----*    *----*----*    *----*----*    *----*----*