指定した文字列のフォントを狙い撃ちで変えるマクロ[Word] - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

Wordで指定した文字列だけ狙い撃ちでフォントを変えるマクロ

文字列単位でフォントを変える

１文字単位でフォントを変える、というのは過去にやったことがあるが、それだと巻き添えで関係のないところまでフォントが変わってしまうので、ちょっとメンドクサかった。

たとえば、「ファラオ」という文字列をゴシックにしたかったとして、「ラはファラオのラ～♪」という文字列に対して「ファ」、「ラ」、「オ」の１字づつをゴシックに変える処理をすると、当然巻き添えで音階を表す「ラ」までゴシックになってしまう、ということだ。

f:id:akashi_keirin:20180127090830j:plain

まあ、完全に巻き添え事故を防ぐことは難しいにせよ、文字列単位でフォントを変える、ということができれば、かなり減らすことはできると考えた。

考え方

ただ、文字列全体から任意の文字列を切り出すだけなら Mid関数を使えば楽勝だが、悲しいことにフォントを変えるためにはFontオブジェクトにアクセスせねばならず、文字列を切り出しても仕方がない。

で、次のように考えた。

まず、文字列全体をCharactersコレクションとして取得する。
x 番目のCharacterオブジェクトから、比較対象文字列（フォントを変えたい文字列）の文字数分だけ切り出して、文字列を作る。
2.で作成した文字列を比較対象文字列と比較する。
3.の結果が同じであれば、 x 番目のCharacterオブジェクトから、 x + (比較対象文字列の文字数) - 1 番目のCharacterオブジェクトまでのFont.Nameプロパティを変更したいフォント名にする。
2.～4.を文字列全体の字数 - 比較対象文字列の字数 + 1 回繰り返す。

このように考えた。

コーディング

上記の考えに基づいて以下のコードを書いた。

リスト1ｰ1　標準モジュール

Public Function applyFontType(ByVal targetSentences As Word.Characters, _
                              ByVal compareTo As String, _
                              ByVal nameOfFont As String) As Boolean
  Dim maxCount As Integer
  maxCount = targetSentences.Count
  Dim wordCount As Integer
  wordCount = Len(compareTo)
  Dim i As Integer
  Dim str As String
  For i = 1 To maxCount - wordCount + 1
    str = assembleWordFromChar(targetSentences:=targetSentences, _
                               extractFrom:=i, _
                               extractTo:=i + wordCount - 1)
    If str = compareTo Then
      Call applyFont(targetSentences:=targetSentences, _
                     startFrom:=i, _
                     endAt:=i + wordCount - 1, _
                     nameOfFont:=nameOfFont)
    End If
  Next
  applyFontType = True
End Function

引数に文字列全体、比較対象文字列、変更したいフォント名を与えると、比較対象文字列の部分のフォントを変え、処理が無事に終わったらTrueを返すFunctionにしている。

リスト1ｰ2　標準モジュール

Private Function assembleWordFromChar(ByVal targetSentences As Word.Characters, _
                                      ByVal extractFrom As Integer, _
                                      ByVal extractTo As Integer) As String
  Dim i As Integer
  Dim str As String
  For i = extractFrom To extractTo
    str = str & targetSentences(i)
  Next
  assembleWordFromChar = str
End Function

こいつは、指定された字数分の文字列をCharactersコレクションから作り出すFunction。

リスト1ｰ3　標準モジュール

Private Sub applyFont(ByVal targetSentences As Word.Characters, _
                      ByVal startFrom As Integer, _
                      ByVal endAt As Integer, _
                      ByVal nameOfFont As String)
  Dim i As Integer
  For i = startFrom To endAt
    targetSentences(i).Font.Name = nameOfFont
  Next
End Sub

んで、こいつが、Charactersコレクションの指定された範囲のFont.Nameプロパティを変更するSub。

ほとんどコイツをそのままコードに置き換えただけ。

実験

次のコードで実行した。

リスト２　標準モジュール

Public Sub testApplyFontType()
  Dim ar As Variant
  ar = Array("ち～んｗ", "プヒー！", "(ﾟДﾟ)ﾊｧ?")
  Dim i As Integer
  For i = 0 To 2
    If Not applyFontType(targetSentences:=Selection.Characters, _
                         compareTo:=ar(i), _
                         nameOfFont:="ＭＳ ゴシック") Then
      Call makeUserSick("失敗ｗｗｗ")
      Exit Sub
    End If
  Next
End Sub

短いコードなので、見たら分かると思うが、配列変数 ar に、「ち～んｗ」、「プヒー！」、「(ﾟДﾟ)ﾊｧ?」の３つの文字列を持たせて、それをForループで回してapplyFontTypeの引数として渡して実行している。

第１引数には、