【Word VBA】音声読み上げ機能の不具合を解消するWordマクロ

2022年3月9日

以前の記事「【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

関連記事

【Word】音声読み上げ機能の不具合の解消方法

-コード
-