カスタム検索
Office関連

 

トップページ > Office関連 > プルダウンからフォントを検索するWordテンプレート

 

Sponsored Links

プルダウンからフォントを検索するWordテンプレート

「指定したフォントが使われているかどうかをチェックする」で紹介しているコードの応用で、プルダウンからフォントを指定して、そのフォントがどこで使われているかをチェックするテンプレートを作成しました(2007以降のリボン対応版はコチラ)。

プルダウンからフォントを検索するWordテンプレート

 

このテンプレート(CheckFont2003.dot)ファイルをWordのスタートアップフォルダにコピーして(スタートアップフォルダを開く際は「Wordのスタートアップフォルダを開く(VBS)」で紹介しているスクリプトが便利です)Wordを起動すると、標準ツールバーにフォントを選択するプルダウンメニューとボタン2つが表示されます。

初回起動時はプルダウン項目がありませんので、隣にある「+」ボタンをクリックして項目を追加してください。



プルダウンからフォントを選択すると実行確認ダイアログが表示されるので、「はい」ボタンをクリックします。

厳密なチェック確認ダイアログが表示されるので、厳密にフォントをチェックする場合(Symbolフォントのチェック等)は「はい」ボタンをクリックし、そうでない場合は「いいえ」ボタンをクリックしてください(「はい」ボタンをクリックすると、日本語用のフォントや英数字用のフォント等、各フォント設定項目のいずれかにフォントが設定されていたらチェック処理を行います)。



ハイライト(蛍光ペン)クリアボタンをクリックすると、文書に設定されたハイライト(蛍光ペン)をクリアします。


当テンプレートが不要になった場合はWordのスタートアップフォルダからテンプレート(CheckFont2003.dot)ファイルを削除してください。
テンプレート削除後もフォント選択プルダウンが表示され続ける場合がありますが、その際は全文書対象テンプレート「Normal.dot」を一度削除することで、元の状態に戻すことができます。

 

Sponsored Links

 

このテンプレートで使用しているコードは下記の通りです。

[標準モジュール]

Option Explicit

Private Const CtrlCaption As String = "CheckFont"

Private Sub ExecuteChkFont()
  Dim r As Word.Range
  Dim mode As Long
  
  If Len(Trim$(Application.CommandBars.ActionControl.Text)) < 1 Then Exit Sub
  If MsgBox("フォントチェックを実行しますか？" & vbCrLf & vbCrLf & _
            "※ 1文字ずつチェックするため、ボリュームの多い文書では時間が掛かる場合があります。" & vbCrLf & _
            "※ チェックを実行すると現在設定されている「蛍光ペン」が無効化されます。", vbYesNo + vbSystemModal + vbInformation) = vbNo Then Exit Sub
  If MsgBox("厳密なチェックを行いますか？" & vbCrLf & vbCrLf & _
            "※ 厳密なチェックを行うと日本語用のフォントや英数字用のフォント等、各フォント設定項目のいずれかにフォントが設定されていたらハイライト処理を行います。" & vbCrLf & _
            "※ Symbolフォントのチェック等に向いています。", _
            vbYesNo + vbSystemModal + vbInformation) = vbYes Then
    mode = 1
  Else
    mode = 2
  End If
  Application.ScreenUpdating = False
  ClearHighlight 'ハイライトクリア
  For Each r In ActiveDocument.Characters
    If ChkFont(r, Application.CommandBars.ActionControl.Text, mode) Then
      r.HighlightColorIndex = wdYellow
    End If
  Next
  Selection.HomeKey unit:=wdStory
  Application.ScreenUpdating = True
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

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

Private Sub AddCboItem()
  Dim cbo As Office.CommandBarComboBox
  Dim f As Variant
  
  On Error Resume Next
  Set cbo = Application.CommandBars("Standard").Controls(CtrlCaption)
  If Err.Number <> 0 Then
    Err.Clear
    Exit Sub
  End If
  On Error GoTo 0
  cbo.Clear
  For Each f In Application.FontNames
    cbo.AddItem f
  Next
  ThisDocument.Save
  Set cbo = Nothing
End Sub

Private Sub ClearHighlight()
  ActiveDocument.Content.HighlightColorIndex = wdNoHighlight
End Sub

トップページ > Office関連 > プルダウンからフォントを検索するWordテンプレート