Office関連

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

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

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

Public Sub Sample1()
  Dim r As Word.Range
  Const SearchFontName As String = "MS ゴシック"
  
  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

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

WordFontFind_01

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

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

Public Sub Sample2()
'※ 下の処理は分かりやすいように冗長に書いています。
  Dim r As Word.Range
  Const SearchFontName As String = "MS ゴシック"
  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

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

WordFontFind_02

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

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

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, "MS ゴシック") = 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プロパティを使って一文字ずつ順番に文字のフォントを調べて、「MS ゴシック」だった場合にのみ処理を行う仕組みになっています。

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

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

WordFontFind_03

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

Public Sub Sample4()
'選択範囲内にある「MS ゴシック」の文字列を「MS 明朝」に変更する
  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, "MS ゴシック") = 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 = "MS 明朝"
  r.Font.NameAscii = "MS 明朝"
  r.Font.NameFarEast = "MS 明朝"
  r.Font.NameOther = "MS 明朝"
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

WordFontFind_04

[Office用アプリ]Excel 2013の操作を動画で学べるアプリ「Excel video tutorials」前のページ

「最速攻略 Wordマクロ/VBA徹底入門」レビュー次のページ

関連記事

  1. Office関連

    名前付きセル(範囲)にコメントを付けるVBAマクロ

    Excelでマニュアルを作成する際、名前付きセル範囲を明記する必要があ…

  2. Office アドイン

    [Office用アプリ]販売者ダッシュボードが日本語化されました。

    当ブログでも下記ページなどで紹介しているSeller Dashboar…

  3. アイコン一覧

    Office 2013 アイコン一覧(X,Y,Z)

    ・Office 2013 アイコン一覧 NUM…

  4. Office関連

    コマンドマクロ一覧(Word 2013)

    Word 2013に組み込まれている「コマンドマクロ」のコマンド名、説…

  5. Office アドイン

    Office 2016で進化したOffice アドイン

    今日OfficeDevを眺めていて気が付いたのが「OfficeJS S…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

PAGE TOP