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 第4版:2014/06/30:変数の定義で、Variant指定を一部Objectに変更した。Application.ScreenRefreshを追加。 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 Object ' VBScript_RegExp_55.RegExp Dim myMatches As Object ' MatchCollection Dim myMatch As Object ' 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 ' Application.ScreenRefresh DoEvents Next ' i End With Rem *----*----* *----*----* *----*----* *----*----* ' MyPhoneticGuideSubExit: Selection.Collapse wdCollapseStart 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 = "[キャンセル]ボタン" .BeginGroup = True .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 *----*----* *----*----* *----*----* *----*----*