キーワードをカッコで括るマクロ(Word)
キーワードをカッコで括るマクロ
Wordドキュメントの中に出てくるキーワードをカッコで括るマクロ。
キーワードの部分を取得する
まずは、キーワードの部分を取得しなければならない。Rangeオブジェクトとして取得すれば、あとは[Range].Textプロパティを書き換えればオッケー。
リスト１
'キーワードを検索し、ヒットした箇所のRangeオブジェクトを返すメソッド'
Private Function getNextRange( _
ByVal tgtText As String) As Range
Dim ret As Range
Set ret = Nothing
With Selection.Find
.Text = tgtText
.Replacement.Text = ""
.Wrap = wdFindStop
.Format = False
.Highlight = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Call Selection.Find.Execute
If Not Selection.Find.Found Then Exit Function
Set ret = Selection.Range
Set getNextRange = ret
End Function
おなじみFindオブジェクトを用いてキーワードを検索する。Find.Executeメソッドを実行すると、キーワードがヒットした場合、その箇所が選択された状態になる。この性質を利用して、Selection.Rangeを参照し、返ってきたRangeオブジェクトを返す。
検索でヒットしなければ、Find.FoundプロパティがFalseを返すので、その場合はNothingを返すことになる。
このメソッドを用いて取得したキーワード部分の[Range].Textプロパティをカッコ付きの文字列に書き換えてやる。
キーワード部分をカッコ付きにする
リスト２
Private Sub test00()
Const NAKED_AHO As String = "アホ"
Const AHO_WITH_BRACKET As String = "［アホ］"
Dim str1 As String, str2 As String
str1 = NAKED_AHO: str2 = AHO_WITH_BRACKET
Call clearFindObject
Dim orgRange As Range
Set orgRange = Selection.Range
Dim tgtRange As Range
Set tgtRange = getNextRange(str1)
Do While Not tgtRange Is Nothing
tgtRange.Font.NameFarEast = "ＭＳ ゴシック"
Call replaceText(str1, str2)
Set tgtRange = getNextRange(str1)
Loop
Call orgRange.Select
Call clearFindObject
End Sub
'Findオブジェクトリセット用メソッド'
Private Sub clearFindObject()
With Selection.Find
Call .ClearFormatting
Call .Replacement.ClearFormatting
End With
End Sub
'文字列置換用メソッド'
Private Sub replaceText(ByVal str1 As String, _
ByVal str2 As String)
'Findオブジェクトをクリア'
Call clearFindObject
'選択範囲を先頭方向に向かって潰す'
Call Selection.Collapse(wdCollapseStart)
Call Selection.Find.Execute(FindText:=str1, _
ReplaceWith:=str2, _
Replace:=wdReplaceOne)
'選択範囲を終端報告に向かって潰す'
Call Selection.Collapse(wdCollapseEnd)
'Findオブジェクトをクリア'
Call clearFindObject
End Sub
ドキュメント内の「アホ」を「［アホ］」に書き換えるマクロ。ついでにフォントをゴシック体に返るようにしている。
実行
このようなドキュメント（笑）を用意し、上掲のリスト２を実行する。
こんな感じ。
もちろん、「アホ」という文字列は問答無用で「［アホ］」に書き換えてしまうので、「ドリルアホールパイルドライバー」が「ドリル［アホ］ールパイルドライバー」になるというまぬけなことも起こるｗ
おわりに
鋭い方は既にお気づきのことと思うが、単に「アホ」を「［アホ］」に書き換えるだけのことなら、
Private Sub test02()
Const NAKED_AHO As String = "アホ"
Const AHO_WITH_BRACKET As String = "［アホ］"
Dim orgRange As Range
Set orgRange = Selection.Range
Call clearFindObject
With Selection.Find
Call .Execute(FindText:=NAKED_AHO, _
ReplaceWith:=AHO_WITH_BRACKET, _
Replace:=wdReplaceAll)
End With
Call clearFindObject
Call orgRange.Select
End Sub
で同じことができるんですけどねｗ
ち～んｗ
Wordドキュメント上で指定した段落以外の段落を折り畳む
Wordドキュメント上で指定した段落以外の段落を折り畳む
段落を折り畳むことができる
知らなかった。
Wordの標準機能にあった。
百聞は一見に如かず。次をご覧いただきたい。
「百聞は一見に如かず」と偉そうに言った割にはわかりにくい画像ですまないｗ
見出しスタイルを当てた段落は、左側に「・」（ポツ）が付く。
んで、このポツにカーソルを近づけると、小さな三角形が表示される。
そいつをクリックしてやると、その見出しに属する本文が折り畳まれたり、展開されたりするのだ。
こいつをVBAで操ってみる。
[Paragraph].CollapsedStateプロパティ
[Paragraph].CollapsedStateというプロパティがある。
こいつがTrueだとその見出しに属する本文が折り畳まれ、Falseだと展開される（表示される）という仕組みらしい。
ちなみに、おなじみコチラの解説によると、
Returns or sets whether the specified paragraph is currently in a collapsed state. Read/write Boolean.
とのこと。
指定した見出しスタイルに指定したキーワードが含まれている段落のみ表示するメソッド
長ったらしくて意味が取りづらくてすまぬ。
たとえば、
このようなドキュメント（笑）があったとして、たとえば、「【安倍晋三内閣総理大臣】」という見出しの段落だけを表示して、他の見出しの段落本文は折り畳んでしまおう、ということ。要するに、
こんな状態にしたい、ということ。
リスト１
Public Sub showOnlySpecifiedParagraph(ByVal tgtDocument As Document, _
ByVal styleNameKey As String, _
Optional ByVal headerKey As String)
'///指定したスタイル名の見出しの段落のみ表示し、他は折り畳む。'
'///headerKeyを指定すれば、そのキーワードを含む見出しの段落のみを表示。'
'///styleNameKey:表示する段落の見出しスタイルの名前（のキーワード）'
'///headerKey: 表示したい見出しのキーワード。'
Dim para As Paragraph
For Each para In tgtDocument.Paragraphs
With para
'段落名にstyleNameKeyが含まれていなければContinue'
If InStr(1, .Style, styleNameKey) = 0 Then GoTo Continue
'headerKeysが指定されていなければ折り畳む'
If headerKey = "" Then _
.CollapsedState = True: GoTo Continue
'段落のテキストにheaderKeyが含まれていなければ折り畳む'
If InStr(1, .Range.Text, headerKey) = 0 Then
.CollapsedState = True
Else
.CollapsedState = False
End If
End With
Continue:
Next
End Sub
処理の手順は細かくコメントを入れたので、それを見ればだいたいわかると思う。
For Each ～ Nextで全ての段落を巡回し、
段落のスタイル名にstyleNameKeyで指定したキーワードが含まれていて、なおかつその見出し段落の文字列にheaderKeyで指定したキーワードが含まれていたら、CollapsedStateプロパティをFalseにし（つまり、折り畳まない。）、それ以外のときはTrueにする（つまり、折り畳む。）
というだけのもの。
このメソッドを、先ほどの
のドキュメント（笑）に対して、次のコードで使ってみる。
リスト２
Private Sub test00()
Call showOnlySpecifiedParagraph(ActiveDocument, _
"見出し 2", _
"安倍晋三")
End Sub
スタイル名に「見出し 2」という文字列を含み、なおかつ見出しに「安倍晋三」という文字列を含む段落の本文だけを残し、他の段落の本文は折り畳む、というマクロ。
コイツを実行すると、
こうなる。
改良
しかし、上掲のshowOnlySpecifiedParagraphメソッド。困ったことに見出しのキーワードが一つしか指定できない。
つまり、たとえば先のドキュメント（笑）の場合、「議長と銭田掏次郎委員の発言だけを表示させたい」という場合には対応できないのだ。
これはイマイチ。
そこで、先の第３引数headerKeyに複数のキーワードが指定できるように改良する。
リスト３
Public Sub showOnlySpecifiedParagraph( _
ByVal tgtDocument As Document, _
ByVal styleNameKey As String, _
Optional ByRef headerKeys As Variant) '……(1)'
'///指定したスタイル名の見出しの段落のみ表示し、他は折り畳む。'
'///headerKeysを指定すれば、そのキーワードを含む見出しの段落のみを表示。'
'///styleNameKey:表示する段落の見出しスタイルの名前（のキーワード）'
'///headerKeys: 表示したい見出しのキーワード。配列か値で渡す'
'headerKeysが省略されていれば、""にする。'
If IsEmpty(headerKeys) Then headerKeys = "" '……(2)'
'headerKeysが配列でなければ、文字列にして要素数1の配列化'
If Not IsArray(headerKeys) Then '……(3)'
headerKeys = Array(CStr(headerKeys))
End If
Dim para As Paragraph
For Each para In tgtDocument.Paragraphs
With para
'段落名にstyleNameKeyが含まれていなければContinue'
If InStr(1, .Style, styleNameKey) = 0 Then GoTo Continue
'headerKeysが指定されていなければ折り畳む'
If headerKeys(0) = "" Then _
.CollapsedState = True: GoTo Continue
'段落のテキストにheaderKeyが含まれていれば折り畳まない'
If isToCollapse(.Range.Text, headerKeys) Then '……(4)'
.CollapsedState = True
Else
.CollapsedState = False
End If
End With
Continue:
Next
End Sub
Private Function isToCollapse( _
ByVal tgtHeaderText As String, _
ByRef tgtArray As Variant) As Boolean '……(5)'
isToCollapse = False
Dim i As Long
For i = LBound(tgtArray) To UBound(tgtArray)
If InStr(1, tgtHeaderText, tgtArray(i)) > 0 Then
Exit Function
End If
Next
isToCollapse = True
End Function
変更したのは(1)～(5)の５箇所。
まず(1)の
Public Sub showOnlySpecifiedParagraph( _
ByVal tgtDocument As Document, _
ByVal styleNameKey As String, _
Optional ByRef headerKeys As Variant)
で第３引数を変更。
Variantにして、文字列でも配列でも受け取れるようにした。
(2)の
If IsEmpty(headerKeys) Then headerKeys = ""
は引数チェックその１。
第３引数が省略されていたら、headerKeysを""にする。
(3)の
If Not IsArray(headerKeys) Then headerKeys = Array(CStr(headerKeys)) End If
は引数チェックその２。
配列でなかったら、値を文字列型にキャストしてheaderKeysに格納。
(4)の
If isToCollapse(.Range.Text, headerKeys) Then .CollapsedState = True Else .CollapsedState = False End If
では、折り畳むかどうかの判定にisToCollapseメソッドを用いている。Trueなら、その段落の本文は折り畳むべし、ということだ。
isToCollapseメソッドは、(5)の
rivate Function isToCollapse( _
ByVal tgtHeaderText As String, _
ByRef tgtArray As Variant) As Boolean
isToCollapse = False
Dim i As Long
For i = LBound(tgtArray) To UBound(tgtArray)
If InStr(1, tgtHeaderText, tgtArray(i)) > 0 Then Exit Function
Next
isToCollapse = True
End Function
このとおり。
引数tgtArrayの要素のうち、どれか一つでも見出し段落の文字列に含まれていたらFalse（つまり、折り畳まんでいい）を返す。
使ってみる
次のコードで実験。
リスト４
Private Sub test01()
Dim var As Variant
var = Array("銭田", "議長")
Call showOnlySpecifiedParagraph(ActiveDocument, _
"見出し 2", _
var)
End Sub
第３引数に「銭田」、「議長」という二つのキーワードを格納した配列を渡す。
コイツを実行すると、
こうなる。無事に「銭田掏次郎委員」と「議長」の発言だけを表示させ、「安倍晋三内閣総理大臣」の発言を折り畳むことができた。
おわりに
議事録なんかで、特定の出席者の発言だけを抽出したいときに便利だと思います。
自作クラスのオブジェクト型デフォルトメンバ……？？？
自作クラスのオブジェクト型デフォルトメンバ……？？？
ちょっと衝撃的な実行結果が出たので報告。
自作クラスにデフォルトメンバを設定する
これは、『VBA Developer's Handbook Second Edition』に載っていたテクニック。
VBA界隈では有名な id:t-hom さんもブログで紹介していたりする。
これをちょっとやってみたのである。
やり方は、ちょっと面倒だけれど簡単。
- クラスモジュールを一旦エクスポートする
- テキストエディタで開く
- デフォルトメンバにしたいプロシージャを選ぶ
- 当該プロシージャの先頭に、
Attribute XXXX.VB_UserMemId = 0（XXXXは、当該プロシージャの識別子）を追加して保存 - プロジェクトに戻って、インポートし直す
これでオッケー。
たとえば、PoweredSheetというクラスモジュールを次のように作成したとする。
リスト１ クラスモジュール PoweredSheet
Option Explicit Private self_ As Worksheet Public Function Self() As Worksheet Set Self = self_ End Function Public Sub init(ByVal tgtSheet As Worksheet) Set self_ = tgtSheet End Sub
モジュールレベル変数self_にWorksheetオブジェクトを持たせておいて、Selfメソッドで返す、というだけのもの。
こいつをエクスポートして、テキストエディタで次のように編集する。
リスト２ エクスポートしたPoweredSheet.cls
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True' END Attribute VB_Name = "PoweredSheet" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private self_ As Worksheet Public Function Self() As Worksheet Attribute Self.VB_UserMemId = 0 '……(*)' Set Self = self_ End Function Public Sub init(ByVal tgtSheet As Worksheet) Set self_ = tgtSheet End Sub
付け加えたのは(*)の1行のみ。
こいつを上書き保存して、もとのプロジェクトにインポートし直す。
オブジェクト ブラウザー を開いてみてみると、
Selfがデフォルトメンバになっていることがわかる。
衝撃の実行結果
問題はここから。
Selfがデフォルトメンバだとは言っても、たとえば、
Private Sub test00() Dim ps As PoweredSheet Set ps = New PoweredSheet Call ps.init(Sh01) Debug.Print ps.Name End Sub
とすれば、psだけでps.Selfのように振る舞ってくれるというわけではない。
そもそもコード入力時に
このようになる。デフォルトメンバであるSelf（Worksheet型）のメンバが自動表示されるわけでもない。
強引にたとえば「ps.Name」と入力したとて、
こうなってしまう。そもそもコンパイルが通らないという屈辱の結果。
ならば、と、
Private Sub test00() Dim ps As PoweredSheet Set ps = New PoweredSheet Call ps.init(Sh01) Dim sh As Worksheet Set sh = ps Debug.Print sh.Name End Sub
としたとしても、
実行時エラーになる。なんたる屈辱……！
秘策、発動す
そこでふと、「これ、カッコで括ったらどうなるんやろ？？？」と思い、やってみた。
リスト３
Private Sub test00() Dim ps As PoweredSheet Set ps = New PoweredSheet Call ps.init(Sh01) Dim sh As Worksheet Set sh = (ps) '……(*)' Debug.Print sh.Name End Sub
変えたのは(*)のところだけ。PoweredSheet型の変数psをカッコで括ってみた。
「カッコで括っていっぺん評価させてみたらいいんでね？」と思いついたのだ。
リスト３を実行してみると……
何ごともなく完走した上、ちゃんとSheet1とイミディエイト ウインドウに出力されている。
まるでPoweredSheetクラスのインスタンスをWorksheet型変数にほぼそのまま突っ込んだみたいになった。
おわりに
ただし、だからといって
(ps).Name
としてもダメです。
このように入力しても、行を移動した途端、
こうなりますｗ
自作クラスにオブジェクト型のデフォルトメンバを設定することは、半分可能、ということでいいのでしょうか。
私としては世紀の発見のつもりなのですが、「そんなもん常識じゃボケ！」なんでしょうか……？？？
選択部分のフィールドコードだけを表示させる(Word)
選択範囲のフィールドコードを表示させる
キーボード上での[Shift] + [ F9 ]（半角モード）をVBAで実現する方法。
これまで、[Window].[View].ShowFieldCodesプロパティのオンオフ（True/False）切り替えしか知らなかった。
ちょこちょこっと調べてみたら、選択範囲のフィールドコードだけを表示させる方法が判明したので、覚書的に記しておく。
FieldオブジェクトのShowCodesプロパティ
早い話、[Field].ShowCodesプロパティのオンオフ（True/False）を切り替えたらよい。それだけ。
リスト１
Private Sub test()
Dim tgtField As Field
Set tgtField = Selection.Fields(1)
With tgtField
.ShowCodes = Not .ShowCodes
End With
End Sub
とりあえず、選択範囲にフィールドコードがあることが前提の決め打ちコード。
フィールドコードのある部分を選択せずにこのコードを実行したら、当然実行時エラーになるので注意。
ドキュメント（笑）上で、
このようにルビが施された部分を選択して、リスト１を何度か実行。
このように、あたかも[Shift] + [ F9 ]を押したかのように、フィールドコードの表示・非表示が切り替えられる。
おわりに
ルビ情報を殺さずにフィールドコードを書き換える(＊)には、
- 一旦フィールドコードを表示させる
Find.Executeメソッドを用いてフィールドコードを置換する- 再度フィールドコードを非表示にする
という非常に面倒な操作が必要っぽいので、いちいち全てのフィールドコードを表示させなくても済む、というのは、処理速度の関係でちょっと有利になるかも知れない。いや、知らんけど。
＊
フィールドコード文字列は、[Field].Code.Textプロパティで取得することができるが、マクロでこのプロパティを書き換えることによってフィールドコードを書き換えた場合、ルビ情報が一部死ぬ。
詳しくは、
コチラをどうぞ。
Range.PhoneticGuideメソッドを使いやすくする(Word)
[Range].PhoneticGuideメソッドを使いやすくする
[Range].PhoneticGuideメソッドはちょい使いにくいので、使いやすく改良。
改良したコード
[Range].PhoneticGuideメソッドは、何といっても引数Raiseが超絶わかりにくい。ゆえに、[Range].PhoneticGuideメソッドをラップして使いやすくした。
リスト１
Private Const MS_P_GOTHIC As String = "ＭＳ Ｐゴシック"
Private Const MS_GOTHIC As String = "ＭＳ ゴシック"
Private Const MS_MINGZHAO As String = "ＭＳ 明朝"
Private Const MS_P_MINGZHAO As String = "ＭＳ Ｐ明朝"
Private Const DEFAULT_RUBYSIZE As Long = 5
Private Sub callPhoneticGuide( _
ByVal tgtRange As Range, _
ByVal tgtRubyText As String, _
ByVal tgtOffset As Long, _
Optional ByVal tgtRubySize As Long = DEFAULT_RUBYSIZE, _
Optional ByVal tgtFontName As String = MS_P_MINGZHAO, _
Optional ByVal tgtAlignment As WdPhoneticGuideAlignmentType = _
wdPhoneticGuideAlignmentOneTwoOne)
'引数で指定されたRangeオブジェクトをSelectする'
Call tgtRange.Select
'一旦右にカーソルを移して親文字のフォントサイズを取得'
Call Selection.MoveRight(wdCharacter, 1, wdMove)
Dim parentFontSize As Single
parentFontSize = Selection.Font.Size
'親文字のフォントサイズと、引数tgtOffsetを元に、Raise値を取得'
Dim tgtRaise As Long
tgtRaise = Int(parentFontSize) - 1 + tgtOffset
'再度親文字を選択状態にし、PhoneticGuideメソッドを実行'
Call tgtRange.Select
Call Selection.Range.PhoneticGuide( _
Text:=tgtRubyText, _
Alignment:=tgtAlignment, _
Raise:=tgtRaise, _
fontSize:=tgtRubySize, _
FontName:=tgtFontName)
'ルビを施した文字列を選択状態にする'
Call Selection.MoveRight(wdCharacter, 1, wdSelection)
End Sub
ちょっと引数祭り状態だが、そもそも[Range].PhoneticGuideメソッドが引数祭りメソッドなので許してほしい。
何といっても、ルビの親文字からの距離を指定できるようにしたことがポイント。
実は、めっちゃめんどくさいことをしている。
'引数で指定されたRangeオブジェクトをSelectする' Call tgtRange.Select '一旦右にカーソルを移して親文字のフォントサイズを取得' Call Selection.MoveRight(wdCharacter, 1, wdMove) Dim parentFontSize As Single parentFontSize = Selection.Font.Size '親文字のフォントサイズと、引数tgtOffsetを元に、Raise値を取得' Dim tgtRaise As Long tgtRaise = Int(parentFontSize) - 1 + tgtOffset
コメントを読んでもらったら、いかにめんどくさいことをしているのか、わかっていただけると思う。
使ってみる
たとえば、
この状態で、
このように「本気」の部分を選択し、次のコードを実行。
リスト２
Private Sub testPhoneticGuide()
Call callPhoneticGuide(tgtRange:=Selection.Range, _
tgtRubyText:="マジ", _
tgtOffset:=1, _
tgtRubySize:=5)
End Sub
すると、
こうなる。
ルビの設定を確認すると、
バッチリ。
さらに、同じ箇所を選択した状態で次のコードを実行。
リスト３
Private Sub testPhoneticGuide()
Call callPhoneticGuide(tgtRange:=Selection.Range, _
tgtText:="マジ", _
tgtOffset:=0, _
tgtRubySize:=5, _
tgtFontName:=MS_P_GOTHIC)
End Sub
今度は、オフセット値を0にし、ルビのフォントを「ＭＳ Ｐゴシック」にしてみる。
すると、
こうなる。
ルビの設定を確認すると、
やはりバッチリ。
おわりに
これで使いやすくなった。
基本、これでルビを設定し、細かなチューニングはフィールドコードをFindオブジェクトを用いて書き換えるようにすれば良い。
安心の実行結果(Word)
安心の実行結果
先日、
このような、衝撃的な実行結果についてお伝えした。
今回は、安心の実行結果である。
フォントサイズは0.5の倍数のみ？
今まであまり気にしたことはなかったのだが、ルビのフィールドコードをいじくっていてちょっと気になったことがあった。
なぜ、ルビのフォントサイズをフォントサイズの2倍の値で取り扱うのか
ということ。
「フォントサイズが6.2とかだったらどうすんだ？ 整数にならんぞ？」と思ったのだ。
で、ちょっとやってみた。
フォントサイズ表示・設定窓に「10.6」を入れてみる
初期状態はこれ。選択箇所のフォントサイズは、見てのとおり「12」だ。
ここに、「10.6」というちゅ～とはんぱな数値を入力してみる。
んで、確定してみると……、
ち～んｗｗｗ
あえなく撃沈ｗ
VBAで設定するとどうなるか
手動でだめなら、VBAで指定するとどうなるのだろうか。
イミディエイト・ウィンドウに
Selection.Font.Size = 10.6
と入力して、[Enter]を押してみる。
フォント名に「ち～んｗ」を指定することはできたが、如何。
おお！ 「10.5」に修正されておる！
おわりに
これは安心！
ルビが施された部分のフォント情報を取得する(Word)
ルビが設定された部分のフォント情報を取得する
選択箇所のフォント情報を取得するときには、Selection.Fontオブジェクトにアクセスすればよい。たとえば、
Selection.Font.Name
とすれば、カーソル位置のフォント名が取得できる。
……はずだ。
ルビが設定されている場合の挙動
次の画像をご覧いただきたい。
「強敵」の直前にカーソルがある。「強敵」の部分は「ＭＳ ゴシック」。その他の部分は「ＭＳ 明朝」である。
このとき、フォント名表示窓の表示は、「ＭＳ 明朝」。
直前の部分のフォント名を表示しているようだ。
次。[Shift]＋[→]で、「強敵」を選択状態にしてみる。
！
フォント名表示窓が空白に!!!!
この状態で、イミディエイト・ウインドウに
?Selection.Characters(1).Text
?Selection.Font.Name
?Selection.Font.Size
の三つを入力して実行してみると、それぞれ
もう、まったくわけのわからない結果が返る。
次に、[→]ボタンを押して、カーソルを「強敵」の直後に持って行く。
フォント名表示窓の表示は、
これは、やはり直前の部分のフォント名を表示しているらしい。
ルビが設定されている箇所のフォント情報を取得する
上記の挙動から、ルビの部分が選択されている状態で選択部分のフォント情報を得るには、
- 一旦カーソルを右に移動する
- フォント情報を取得する
- 選択状態に戻す
という操作が必要であると考えた。
ルビが施された親文字のフォント情報を取得する
リスト１
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オブジェクトを選択する。
実行結果
イミディエイトの出力はバッチリ。
ドキュメント（笑）の方も、見かけ上は元どおり。
うむ！
おわりに
ただ、同じ選択範囲に異なるフォントがチャンポンになっていたら詰む……？
