Office関連

徹底的にSymbol(シンボル)フォントをチェックするWordマクロ

文字列をメモ帳にコピー&ペーストすると文字化けしたり、フォント指定で検索しているのに何故かヒットしなかったり、Wordマクロを書く人間にとって何かと厄介なのが“Symbol(シンボル)フォント”です。

ライターや翻訳者など、大量の文字をWordで扱ったことがある人ならば、一度は引っ掛かったことがあるのではないでしょうか?

Word MVPの新田さんのブログにも、このSymbolフォントを扱っている記事が数多くあります。

私も数年前にHPで「指定したフォントが使われているかどうかをチェックする」というWordマクロのコードを書いたのですが、以前書いたコードは非効率的な部分もあるので、今回改めてコードを見直すことにしました。

Option Explicit

Public Sub Sample()
'"Symbol"フォントかどうかを一文字ずつチェック
  Dim tmp As Word.Range
  Dim r As Word.Range
  
  Set tmp = Selection.Range
  Application.ScreenUpdating = False
  For Each r In ActiveDocument.Characters
    If ChkSymbolFont(r) = True Then
      '"Symbol"フォントだったら蛍光ペンでマーク
      r.HighlightColorIndex = wdPink
    End If
  Next
  Application.ScreenUpdating = True
  tmp.Select
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Function ChkSymbolFont(ByVal TargetCharacter As Word.Range) As Boolean
'指定したRange(1文字)のフォントが「Symbol」かどうかをチェック
  Dim FontName As String: FontName = LCase("Symbol")
  Dim ret As Boolean
  
  '文字数チェック
  If TargetCharacter.Characters.Count > 1 Then _
     Err.Raise Number:=513, Description:="引数の文字数を「1」にしてください。"
  
  '初期化
  ret = False
  TargetCharacter.Select
  
  'Fontオブジェクトのプロパティチェック
  With Selection
    If LCase(.Font.Name) = FontName Then ret = True: GoTo EndProc
    If LCase(.Font.NameAscii) = FontName Then ret = True: GoTo EndProc
    If LCase(.Font.NameBi) = FontName Then ret = True: GoTo EndProc
    If LCase(.Font.NameFarEast) = FontName Then ret = True: GoTo EndProc
    If LCase(.Font.NameOther) = FontName Then ret = True: GoTo EndProc
  End With

  'フォントダイアログチェック
  With Application.Dialogs(wdDialogFormatFont)
    If LCase(.Font) = FontName Then ret = True: GoTo EndProc
    If LCase(.FontHighAnsi) = FontName Then ret = True: GoTo EndProc
    If LCase(.FontLowAnsi) = FontName Then ret = True: GoTo EndProc
    If LCase(.FontNameBi) = FontName Then ret = True: GoTo EndProc
  End With

  '記号と特殊文字ダイアログチェック
  With Application.Dialogs(wdDialogInsertSymbol)
    If LCase(.Font) = FontName Then ret = True: GoTo EndProc
  End With
  
EndProc:
  ChkSymbolFont = ret
End Function

やっていることは以前書いたコードと同じで、一文字ずつチェック用の関数に渡して、文書中のどこにSymbolフォントがあるのかをチェックする、というものです。

Fontオブジェクトからフォント名関連の各プロパティをチェック、フォントダイアログから取得できる各フォント名をチェック、記号と特殊文字ダイアログから取得できるフォント名をチェック、これだけやればさすがに漏れなくチェックできるのではないかと思います。

ホントは下記コードのようにRangeやSelectionか取得できるXMLから判別する方法も考えたのですが、効率が悪そうなので止めにしました。

Dim node As Object
Dim attr As Object

With CreateObject("MSXML2.DOMDocument")
  If .LoadXML(Selection.XML) = True Then
    Set node = .SelectSingleNode("/w:wordDocument/w:body/wx:sect/w:p/w:r/w:sym")
    If Not node Is Nothing Then
      Set attr = node.Attributes.getNamedItem("w:font")
      If Not attr Is Nothing Then
        If LCase(attr.NodeValue) = LCase("Symbol") Then MsgBox "Symbolフォントです。"
      End If
    End If
  End If
End With

一文字ずつのチェックになるため、動作速度としては速いものではありませんが、Symbolフォントの対応に苦慮されている方の参考になれば幸いです。

関連記事

  1. Office関連

    選択範囲内で文字列検索を行うWordマクロ

    今日は選択範囲内で文字列検索を行うWordマクロについて考えてみます。…

  2. Office関連

    指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelアドイン

    以前この記事で、指定したセル範囲をUTF-8やEUC-JP等のテキスト…

  3. Office関連

    「ちゃうちゃう!」で2つの文書を比較するWordマクロ

    2014/08/10 追記:ちゃうちゃう!がバージョンアップされま…

  4. Office関連

    格子状にガイドを追加するPowerPointマクロ

    前回の記事で、PowerPoint 2013で追加されたGuide、G…

  5. Office関連

    Adobe Reader XIを利用してPDFファイルのページ数を取得するVBAマクロ

    先日Adobe Readerを利用してPDFファイルのページ数を取得す…

  6. Office関連

    1MBのWordファイルって何文字くらい?

    ZIP圧縮されたOOXML形式のWordファイルって1MBだと何文字分…

コメント

  • コメント (0)

  • トラックバックは利用できません。

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP