ルビ(ふりがな)を一括設定するWordマクロ

ホーム
Office関連, Word
ルビ(ふりがな)を一括設定するWordマクロ

Office関連

2014.07.2

ルビ(ふりがな)を一括設定するWordマクロ

2016/10/28 追記：
改良版のマクロを書きました。

2016.10.28

ルビ(ふりがな)を一括設定するWordマクロ(改良版)

これまで当ブログではルビを設定するWordマクロについて、いくつか記事を書いてきました。それらはExcelを利用するものであったり、ルビダイアログを無理やり操作するものであったりして、あまり実用的ではないレベルのマクロでした。 ...

Wordの標準機能ではルビ(ふりがな)を一括設定できない、ということを最近知ったので、マクロで処理できないか色々調べてみました。

まずは関連がありそうなメソッドですが、WordのRangeオブジェクトには指定範囲にルビを追加する、そのものずばりのPhoneticGuideメソッドが用意されています。

ただし、上図の通り追加するルビ文字列を指定する「Text」パラメータが必須となっているため、自分でルビを設定する必要があります。

ここで気になったのがWordの「ルビ」機能で、この機能を実行すると、自分でルビを設定することなく、下図のように自動的にルビが設定されます。

この自動的に設定されるルビを何らかの方法で取得できれば、PhoneticGuideメソッドを活かすことができそうです。

早速、ダイアログボックスの設定値を取得するための引数を「組み込みのダイアログボックスの引数一覧 (Word)」で調べてみました。

・・・が、上図の通りwdDialogPhoneticGuideには引数がありませんでした。

仕方がないので「ルビ」を実行したときにWordがどのような動きをしているのかをProcess Explorerで調べたところ、どうやらWord 2010ではimjp14k.dllの「CreateIImeGrammarInstance」関数が呼ばれているようでした。

imjp14k.dllはIMEで使われているDLLなので、恐らくはIMEを利用してルビを取得しているだろうことは分かったのですが、呼ばれている関数が分かったところでCreateIImeGrammarInstance関数について調べても目ぼしい情報が出てきませんでしたので、ルビを取得する関数を直接呼び出す方法は諦めることにしました。

そこで目を付けたのがExcelのApplicationオブジェクトにあるGetPhoneticメソッドです。
このメソッドは指定した文字列の日本語のふりがなを取得するもので、挙動を調べたところ、Wordのルビと同様imjp14k.dllのCreateIImeGrammarInstance関数が呼び出されているようでした。

“ExcelのGetPhoneticメソッドで取得したルビをWordのPhoneticGuideメソッドで設定する”

という方向が決まったところで書いたのが下記コードになります。
(Wordのルビダイアログから直接取得する方法も考えましたが、面倒なので止めました。)

Option Explicit

Public Sub SetPhoneticDocument()
'ルビ一括設定
  Dim r As Word.Range
  Dim pntc As String
  
  With CreateObject("Excel.Application")
    .Visible = True
    '単語単位で処理
    For Each r In ActiveDocument.Words
      If ChkKanjiRange(r) = True Then
        pntc = .GetPhonetic(r.Text)
        r.PhoneticGuide StrConv(pntc, vbHiragana)
      End If
    Next
    '文字単位で処理
    For Each r In ActiveDocument.Characters
      If ChkKanjiRange(r) = True Then
        pntc = .GetPhonetic(r.Text)
        r.PhoneticGuide StrConv(pntc, vbHiragana)
      End If
    Next
    .Quit
  End With
End Sub

Private Function ChkKanjiRange(ByVal rng As Word.Range) As Boolean
'指定したRangeが漢字のみかチェック
  Dim ret As Boolean
  Dim i As Long
  
  ret = True
  For i = 1 To Len(rng.Text)
    If IsKanji(Mid(rng.Text, i, 1)) = False Then
      ret = False
      Exit For
    End If
  Next
  ChkKanjiRange = ret
End Function

Private Function IsKanji(ByVal char As String) As Boolean
'漢字判別
'※ 参考Webページ
' - http://www.taishukan.co.jp/kokugo/webkoku/series003_04.html
' - http://en.wikipedia.org/wiki/CJK_Unified_Ideographs_%28Unicode_block%29
' - http://www.asahi-net.or.jp/~ax2s-kmtn/ref/unicode/e_asia.html
' - http://www.gsid.nagoya-u.ac.jp/ohna/notes/nu/regex4kanji2.txt
' - http://support.microsoft.com/kb/161304/ja
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  'Debug.Print "CHK:" & cc
  Select Case cc
    Case 19968 To 40959   'CJK統合漢字(U+4E00-U+9FFF)
    Case 13312 To 19903   'CJK統合漢字拡張A(U+3400-U+4DBF)
    Case 131072 To 173791 'CJK統合漢字拡張B(U+20000-U+2A6DF)
    Case 173824 To 177983 'CJK統合漢字拡張C(U+2A700-U+2B73F)
    Case 177984 To 178207 'CJK統合漢字拡張D(U+2B740-U+2B81F)
    Case 63744 To 64255   'CJK互換漢字(U+F900-U+FAFF)
    Case 194560 To 195103 'CJK互換漢字補助(U+2F800-U+2FA1F)
    Case Else
      ret = False
  End Select
  IsKanji = ret
End Function

まずは単語単位で列挙していき、単語が漢字である場合にルビを設定、漏れ防止に文字単位で列挙していき、文字が漢字である場合にルビを設定する、といった処理を行っています。