WordVba ルビをすべて解除する方法は？

質問

高校の授業で生徒が自己採点できる教材を作っています。自己採点のマクロとは直接関係はないのですが、マクロの勉強を兼ねて、次のような課題を解決したいと思ったのですが無理でした。
生徒向け表示用のワード文書で読みにくい漢字にルビを設定したものが100ファイル（600文字～1000文字）ほどあります。ルビをふっていない文書が必要になったのですが、ルビを設定していない素の文書が見つからないのでVbaを使ってルビをすべて解除したいと思っています。
「MSDNのWord VBA リファレンス ＞　オブジェクト モデル ＞　Range オブジェクト」を参照して、Range.PhoneticGuideメソッドを使えばできそうなので次のようなプロシジャー作り、実行したら手作業のときと同じような結果（ルビが解除できる場所と個数が私には予想できない）になりました。

Sub ReSetPhonetic()
ActiveDocument.Range(Start:=200, End:=500).Select
Selection.Range.PhoneticGuide Text:="", _
Alignment:=wdPhoneticGuideAlignmentCenter, _
Raise:=11, FontSize:=7
End Sub

ルビをふってあるRangeオブジェクトを正確に指定する方法が分からないので、それを含むであろう範囲をStrat、Endに適当に設定して実行してますが、ルビが解除される場所がよく分かりません。複数のルビをふった文字列を一括で解除する方法をどなたか教えていただけませんか。よろしくお願いします。

回答No.3

Prome_Lin

こんなサイトを見つけました。

http://www.wordvbalab.com/code/4236/

試してみたところ、確かに、すべてのルビが削除されました。

Sub DeleteRuby()
Dim myField As Field
Dim myRange As Range
Application.ScreenUpdating = False
Set myRange = Selection.Range
For Each myField In ActiveDocument.Fields
If myField.Type = wdFieldFormula Then
If InStr(1, myField.Code.Text, "\s\up") > 0 Then
myField.Select
Selection.Range.PhoneticGuide ""
End If
End If
Next
myRange.Select
Set myRange = Nothing
Application.ScreenUpdating = True
End Sub

回答No.2

kagakusuki

例えばルビの消去を手動で行う場合には、まず、Wordのウィンドウの上の方に並んでいるタブの中の[ホーム]タブをクリックし、現れた「編集グループ」の中にある[検索]ボタンをクリックし、現れた選択肢の中にある[ジャンプ]を選択しますと、「検索と置換」ダイアログボックスの[ジャンプ]タブが開きますが、その[ジャンプ]タブにおいて、「移動先」欄で[フィールド]を選択し、「フィールド名」欄で[EQ]を選択してから、[前へ]ボタンや[次へ]ボタンをクリックしますと、ルビが降られている箇所の直前の所へとカーソルが自動的に移動します。
　その上で、Wordのウィンドウの[ホーム]タブの「フォント」グループ内にある[ルビ]ボタンをクリックし、現れた「ルビ」ダイアログボックスの[ルビの解除]ボタンをクリックしてから[OK]をクリックしますと、その箇所のルビを消す事が出来ます。
　この操作を繰り返す事で次々とルビを消す事が出来る訳です。

　そこで、[検索]ボタン等を使わずとも、上記の操作を全て自動で行う様にする事で、そのWord文書内の全てのルビを消す事が出来る様にしたものが下記のVBAのマクロです。

　尚、万が一、Do～Loopの無限ループに陥った際の対策のために、ループが1回回るごとにLong変数 i の値を1ずつ増やして行き、i の値が99999を超えた時点で無限ループに陥っているものと判断して、自動的にループから抜け出す様になっているのですが、そのためにルビが振られている箇所が10万か所以上ある文書の場合には、99999箇所目までしかルビを消す事が出来ません。
　もしそれでは不足である場合には、VBAの構文中において

Loop Until m = n Or i > 99999

と記されている箇所の末尾にある99999という数値をもっと大きな数値に変更して下さい。

Sub ルビの自動削除()

Dim i As Long, m As Long, n As Long

Application.ScreenUpdating = False
With Selection
.GoTo What:=wdGoToLine, Which:=wdGoToFirst
n = -9
Do
.GoTo What:=wdGoToField, Which:=wdGoToNext, Name:="EQ"
.Range.PhoneticGuide Text:=""
m = n
n = .Start
i = i + 1
Loop Until m = n Or i > 99999
End With
Application.ScreenUpdating = True

End Sub

回答No.1

f272

ルビをふってあるRangeオブジェクトを正確に指定する方法はよくわからないので，そういうことをやりたいときは
Sub RemoveRuby()
ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "EQ*\),(*)\)"
.Replacement.Text = "COMMENTS \1"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.WholeStory
Selection.Fields.Update
ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
Selection.Fields.Unlink
End Sub
でやってます。

お礼

ありがとうございました。そのままコピペして実行すればうまくいきました。これで生徒のタイピングの課題ファイルを自動採点する際の正解ファイルがすぐに作成できます。ひとまず2学期末の成績処理をしてから、その後Wordのマクロコードをじっくり勉強します。WordVbaで処理したい課題がたくさんあるのですが、Vbaの力を実感でき意欲が高まりました。本当にありがとうございました。