[Word VBA]ルビ(ふりがな)ダイアログの操作に挑む(2)

ホーム
Office関連, Word
[Word VBA]ルビ(ふりがな)ダイアログの操作に挑む(2)

Office関連

2015.10.22

[Word VBA]ルビ(ふりがな)ダイアログの操作に挑む(2)

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

2016.10.28

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

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

前回の記事では、Wordのルビダイアログの操作に挑んで見事につまづいたわけですが、対処は簡単です。
配置やオフセット、フォントといったオプションの設定で上手くいかないのであれば、ダイアログでそれらの設定を行わなければ良いわけです。

'ThisDocument
Option Explicit

Private d As Object

Public Sub Sample()
  If Selection.Start <> Selection.End Then
    Set d = CreateObject("htmlfile")
    Set d.parentWindow.onhelp = Me
    d.parentWindow.SetTimeout "onhelp.SetPhoneticDialog()", 100, "VBScript" 'setTimeoutで時間差実行
    Application.Dialogs(wdDialogPhoneticGuide).Show
  End If
End Sub

Public Sub SetPhoneticDialog(Optional ByVal dummy As Long = 0)
'[ルビ]ダイアログ操作
'※UIAutomationClient(UIAutomationCore.dll)要参照
  
  Dim uiAuto As CUIAutomation
  Dim elmRoot As IUIAutomationElement
  Dim elmPhoneticDialog As IUIAutomationElement 'ルビダイアログ
  Dim elmOkButton As IUIAutomationElement 'OK
  Dim elmRubyEdit As IUIAutomationElement 'ルビ
  Dim iptn As IUIAutomationInvokePattern
  
  Set uiAuto = New CUIAutomation
  Set elmRoot = uiAuto.GetRootElement
  
  '[ルビ]ダイアログ取得
  While elmPhoneticDialog Is Nothing
    Set elmPhoneticDialog = GetElement(uiAuto, elmRoot, UIA_NamePropertyId, "ルビ", UIA_WindowControlTypeId)
    DoEvents
  Wend
  '[OK]ボタン取得
  Set elmOkButton = GetElement(uiAuto, elmPhoneticDialog, UIA_NamePropertyId, "OK", UIA_ButtonControlTypeId)
  '[ルビ]エディットボックス取得
  Set elmRubyEdit = GetElement(uiAuto, elmPhoneticDialog, UIA_AutomationIdPropertyId, "19")
  If Len(Trim(elmRubyEdit.GetCurrentPropertyValue(UIA_ValueValuePropertyId))) < 1 Then
    elmRubyEdit.SetFocus
  Else
    '[OK]ボタンクリック
    Set iptn = elmOkButton.GetCurrentPattern(UIA_InvokePatternId)
    iptn.Invoke
  End If
End Sub

Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0)
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition
  
  Set cndFirst = uiAuto.CreatePropertyCondition(propertyId, propertyValue)
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, ctrlType)
    Set cndFirst = uiAuto.CreateAndCondition(cndFirst, cndSecond)
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function

上記の通り、“OKボタンを押す操作だけ”行うようにした結果、前回の記事のコードに比べて大分シンプルになりました。
前回つまづいたWord 2016での動作も問題ありません。

これでようやくルビダイアログが操作できるようになったので、あとは一括ふりがな設定をするべく、マクロを連続で実行するだけです。

選択範囲にある漢字にルビを一括設定するWordマクロ

連続で実行と言っても、処理手順は「ルビ(ふりがな)を一括設定するWordマクロ」で書いている通り、“単語単位で列挙していき、単語が漢字である場合にルビを設定、漏れ防止に文字単位で列挙していき、文字が漢字である場合にルビを設定”していけば良いだけです。

'ThisDocument
Option Explicit

Private d As Object

Public Sub Sample2()
  Dim sel As Word.Range
  Dim r As Word.Range
  
  Set d = CreateObject("htmlfile")
  Set d.parentWindow.onhelp = Me
  Set sel = Selection.Range
  
  '単語単位で処理
  For Each r In sel.Words
    If ChkKanjiRange(r) = True Then
      r.Select
      d.parentWindow.SetTimeout "onhelp.SetPhoneticDialog()", 100, "VBScript" 'setTimeoutで時間差実行
      Application.Dialogs(wdDialogPhoneticGuide).Show
    End If
  Next
  
  '文字単位で処理
  For Each r In sel.Characters
    If IsKanji(r.Text) = True Then
      r.Select
      d.parentWindow.SetTimeout "onhelp.SetPhoneticDialog()", 100, "VBScript" 'setTimeoutで時間差実行
      Application.Dialogs(wdDialogPhoneticGuide).Show
    End If
  Next
  
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Public Sub SetPhoneticDialog(Optional ByVal dummy As Long = 0)
'[ルビ]ダイアログ操作
'※UIAutomationClient(UIAutomationCore.dll)要参照
  
  Dim uiAuto As CUIAutomation
  Dim elmRoot As IUIAutomationElement
  Dim elmPhoneticDialog As IUIAutomationElement 'ルビダイアログ
  Dim elmOkButton As IUIAutomationElement 'OK
  Dim elmRubyEdit As IUIAutomationElement 'ルビ
  Dim iptn As IUIAutomationInvokePattern
  
  Set uiAuto = New CUIAutomation
  Set elmRoot = uiAuto.GetRootElement
  
  '[ルビ]ダイアログ取得
  While elmPhoneticDialog Is Nothing
    Set elmPhoneticDialog = GetElement(uiAuto, elmRoot, UIA_NamePropertyId, "ルビ", UIA_WindowControlTypeId)
    DoEvents
  Wend
  '[OK]ボタン取得
  Set elmOkButton = GetElement(uiAuto, elmPhoneticDialog, UIA_NamePropertyId, "OK", UIA_ButtonControlTypeId)
  '[ルビ]エディットボックス取得
  Set elmRubyEdit = GetElement(uiAuto, elmPhoneticDialog, UIA_AutomationIdPropertyId, "19")
  If Len(Trim(elmRubyEdit.GetCurrentPropertyValue(UIA_ValueValuePropertyId))) < 1 Then
    elmRubyEdit.SetFocus
  Else
    '[OK]ボタンクリック
    Set iptn = elmOkButton.GetCurrentPattern(UIA_InvokePatternId)
    iptn.Invoke
  End If
End Sub

Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0)
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition
  
  Set cndFirst = uiAuto.CreatePropertyCondition(propertyId, propertyValue)
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, ctrlType)
    Set cndFirst = uiAuto.CreateAndCondition(cndFirst, cndSecond)
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function

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
'漢字判別
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  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

仕組みとしては上記コードで問題なく処理できるはずです。
・・・が、いざ実行してみると、