以前の記事「【Word】音声読み上げ機能の不具合の解消方法」で、段落先頭に全角記号を挿入してWordの音声読み上げ機能の不具合を解消するという裏技を紹介しました。
本記事では、この全角機能の挿入と削除を自動化するためのWordマクロを紹介します。
このマクロでできること
対象の文書の段落先頭に●を追加します。
（実行前）
（実行後）
また、別の削除用のマクロを使えば、音読後に挿入した記号を削除もできます。
マクロの解説
●を挿入するマクロと削除するマクロの2種類があります。
いずれのマクロにもUndoRecordオブジェクトを使用して［Ctrl］+［Z］のショートカットキーで1回で元に戻せるようにしています。
全角記号として挿入するのは●以外にもなんでもかまいません。文書で使われていない記号にしてください。
今回のマクロでは処理対象がわかりやすいので一括置換をしていますが、蛍光ペンでの着色はしていません。
記号や蛍光ペンの処理については好みに応じて修正して使ってみてください。
なお、段落先頭に文字列「●」を挿入する場合、「段落記号」+「●」として定義をして置換をします。
そのため、文書先頭への文字列の挿入が置換ではできないため、別途処理を追加しています。（挿入マクロ、削除マクロともに16行目）
マクロ（●挿入）
Sub 段落先頭に●を挿入するWordマクロ()
'-------------------------------------------
'UndoRecordの利用
'-------------------------------------------
#If VBA7 Then
Dim objUndo As UndoRecord
Set objUndo = Application.UndoRecord
objUndo.StartCustomRecord ("●を挿入")
#End If
'-------------------------------------------
'処理の実行
'-------------------------------------------
'文書先頭に●を挿入
ActiveDocument.Range.InsertBefore "●"
'文書全体の段落先頭に●を挿入
Dim myRange As Range: Set myRange = ActiveDocument.Range(0, 0)
With myRange.Find
.Text = "^p"
.Replacement.Text = "^p●"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
DoEvents
End With
Set myRange = Nothing
'-------------------------------------------
'UndoRecordの利用
'-------------------------------------------
#If VBA7 Then
objUndo.EndCustomRecord
Set objUndo = Nothing
Application.ScreenRefresh
#End If
End Sub
マクロ（●削除）
Sub 段落先頭の●を削除するWordマクロ()
'-------------------------------------------
'UndoRecordの利用
'-------------------------------------------
#If VBA7 Then
Dim objUndo As UndoRecord
Set objUndo = Application.UndoRecord
objUndo.StartCustomRecord ("●を削除")
#End If
'-------------------------------------------
'処理の実行
'-------------------------------------------
'文書先頭の●を削除
If ActiveDocument.Range.Characters.First = "●" Then
ActiveDocument.Range.Characters.First.Delete
End If
'文書全体の段落先頭の●を削除
Dim myRange As Range: Set myRange = ActiveDocument.Range(0, 0)
With myRange.Find
.Text = "^p●"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
DoEvents
End With
Set myRange = Nothing
'-------------------------------------------
'UndoRecordの利用
'-------------------------------------------
#If VBA7 Then
objUndo.EndCustomRecord
Set objUndo = Nothing
Application.ScreenRefresh
#End If
End Sub
