選択範囲内にある特定のフォントの文字列を別のフォントに置き換えるWordマクロ

ホーム
Office関連, Word
選択範囲内にある特定のフォントの文字列を別のフォントに置き換えるWordマクロ

2013.09.13

選択範囲内にある特定のフォントの文字列を別のフォントに置き換えるWordマクロ

選択範囲内で「ＭＳゴシック」が使われている文字列のフォントを「ＭＳ明朝」にマクロで変更したい、という質問がありましたので処理を考えてみました。

「選択範囲内で文字列検索を行うWordマクロ」を当ブログで紹介したことがありましたが、このマクロをフォント(ＭＳゴシック)を検索する形に直すと下記のようになります。

Public Sub Sample1()
  Dim r As Word.Range
  Const SearchFontName As String = "ＭＳ ゴシック"
  
  Set r = Selection.Range
  '選択範囲が指定したフォントかどうかを判断
  If r.Font.Name = SearchFontName Then
    HitProc r
  Else
    With r.Find
      .Font.Name = SearchFontName
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = False
      Do While .Execute
        '選択範囲内の場合のみ処理実行
        If r.InRange(Selection.Range) Then
          HitProc r
        End If
      Loop
    End With
  End If
End Sub

Private Sub HitProc(ByRef r As Word.Range)
'ヒットした場合の処理
  r.Bold = True
  r.Italic = True
  r.Font.Color = wdColorWhite
  r.HighlightColorIndex = wdRed
End Sub

テスト用の文書でこのマクロを実行したところ、結果は下図のようになりました。

マクロで処理されたのは「タブ」と「文書」だけで、他のＭＳゴシックの文字列「挿入」や「ギャラリー」、「全体」は処理されていません。

これは、それらの文字列のフォントが「ＭＳゴシック (見出しのフォント – 日本語)」となっているためで、これらの文字も含めて処理するためには、

Public Sub Sample2()
'※ 下の処理は分かりやすいように冗長に書いています。
  Dim r As Word.Range
  Const SearchFontName As String = "ＭＳ ゴシック"
  Const SearchFontName2 As String = "+見出しのフォント - 日本語"
  
  Set r = Selection.Range
  '選択範囲が指定したフォントかどうかを判断
  If r.Font.Name = SearchFontName Then
    HitProc r
  Else
    With r.Find
      .Font.Name = SearchFontName
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = False
      Do While .Execute
        '選択範囲内の場合のみ処理実行
        If r.InRange(Selection.Range) Then
          HitProc r
        End If
      Loop
    End With
  End If
  
  Set r = Selection.Range
  '選択範囲が指定したフォントかどうかを判断
  If r.Font.Name = SearchFontName2 Then
    HitProc r
  Else
    With r.Find
      .Font.Name = SearchFontName2
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchByte = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = False
      Do While .Execute
        '選択範囲内の場合のみ処理実行
        If r.InRange(Selection.Range) Then
          HitProc r
        End If
      Loop
    End With
  End If
End Sub

Private Sub HitProc(ByRef r As Word.Range)
'ヒットした場合の処理
  r.Bold = True
  r.Italic = True
  r.Font.Color = wdColorWhite
  r.HighlightColorIndex = wdRed
End Sub

上記のように「見出しのフォント」も検索しなくてはいけません。

また、上記のコードではFontオブジェクトの「Name」プロパティしか指定していませんが、Fontオブジェクトにはそれ以外にも「NameAscii」「NameBi」「NameFarEast」「NameOther」といったプロパティも有り、文書によってはこれらのプロパティも考慮する必要があります。

そのため、当初の目的であった「ＭＳゴシック」を検索して処理するには、各プロパティを対象にして複数回検索を実行することが必要になるのですが、それをしてしまうと、処理が煩雑になってしまうため、今回は別の方向性として“一文字ずつ順番に文字のフォントを調べて処理を行うマクロ”を考えてみました。

Public Sub Sample3()
  Dim sel As Word.Range
  Dim r As Word.Range
  
  Set sel = Selection.Range
  Application.ScreenUpdating = False
  For Each r In sel.Characters
    If ChkFont(r, "ＭＳ ゴシック") = True Then
      HitProc r
    End If
  Next
  Application.ScreenUpdating = True
  sel.Select
End Sub

Private Sub HitProc(ByRef r As Word.Range)
'ヒットした場合の処理
  r.Bold = True
  r.Italic = True
  r.Font.Color = wdColorWhite
  r.HighlightColorIndex = wdRed
End Sub

Private Function ChkFont(ByVal Target As Word.Range, ByVal FontName As String) As Boolean
  Dim ret As Boolean
  Dim dlg As Word.Dialog
  
  ret = False '初期化
  Target.Select
  Set dlg = Application.Dialogs(wdDialogFormatFont)
  If Selection.Font.Name = FontName Then
    ret = True
  ElseIf Selection.Font.NameAscii = FontName Then
    ret = True
  ElseIf Selection.Font.NameBi = FontName Then
    ret = True
  ElseIf Selection.Font.NameFarEast = FontName Then
    ret = True
  ElseIf Selection.Font.NameOther = FontName Then
    ret = True
  ElseIf dlg.Font = FontName Then
    ret = True
  ElseIf dlg.FontHighAnsi = FontName Then
    ret = True
  ElseIf dlg.FontLowAnsi = FontName Then
    ret = True
  ElseIf dlg.FontNameBi = FontName Then
    ret = True
  ElseIf Application.Dialogs(wdDialogInsertSymbol).Font = FontName Then
    ret = True
  End If
  ChkFont = ret
End Function

上記コードでは、RangeオブジェクトのCharactersプロパティを使って一文字ずつ順番に文字のフォントを調べて、「ＭＳゴシック」だった場合にのみ処理を行う仕組みになっています。

(フォントをチェックするChkFontプロシージャーでは、Fontオブジェクトの各プロパティ、フォントダイアログの各項目、記号と特殊文字ダイアログのフォント欄を一つずつチェックしていますが、これは以前一部のシンボルフォントが検索に引っ掛からなかったことがあり、その対応として細かくチェックするようにしているためで、通常はここまで指定する必要はありません。)

上記コードを実行すると、一文字ずつチェックしている仕様上時間は掛かりますが、下図の通り意図通りの処理が行われています。

上記コードでは、視覚的に分かりやすいようにヒットした文字の色や太字設定などを変更するようにしていますが、下記のようにHitProcプロシージャーの処理を目的に合わせて変更すれば、最初の質問にあるように、選択範囲内にある特定のフォントの文字列を別のフォントに置き換えることができます。

Public Sub Sample4()
'選択範囲内にある「ＭＳ ゴシック」の文字列を「ＭＳ 明朝」に変更する
  Dim sel As Word.Range
  Dim r As Word.Range
  
  Set sel = Selection.Range
  Application.ScreenUpdating = False
  For Each r In sel.Characters
    If ChkFont(r, "ＭＳ ゴシック") = True Then
      HitProc r
    End If
  Next
  Application.ScreenUpdating = True
  sel.Select
End Sub

Private Sub HitProc(ByRef r As Word.Range)
'ヒットした場合の処理
  r.Font.Name = "ＭＳ 明朝"
  r.Font.NameAscii = "ＭＳ 明朝"
  r.Font.NameFarEast = "ＭＳ 明朝"
  r.Font.NameOther = "ＭＳ 明朝"
End Sub

Private Function ChkFont(ByVal Target As Word.Range, ByVal FontName As String) As Boolean
  Dim ret As Boolean
  Dim dlg As Word.Dialog
  
  ret = False '初期化
  Target.Select
  Set dlg = Application.Dialogs(wdDialogFormatFont)
  If Selection.Font.Name = FontName Then
    ret = True
  ElseIf Selection.Font.NameAscii = FontName Then
    ret = True
  ElseIf Selection.Font.NameBi = FontName Then
    ret = True
  ElseIf Selection.Font.NameFarEast = FontName Then
    ret = True
  ElseIf Selection.Font.NameOther = FontName Then
    ret = True
  ElseIf dlg.Font = FontName Then
    ret = True
  ElseIf dlg.FontHighAnsi = FontName Then
    ret = True
  ElseIf dlg.FontLowAnsi = FontName Then
    ret = True
  ElseIf dlg.FontNameBi = FontName Then
    ret = True
  ElseIf Application.Dialogs(wdDialogInsertSymbol).Font = FontName Then
    ret = True
  End If
  ChkFont = ret
End Function