いかちソフトウェア

フォントインストーラーの作成

トップ > テクニック

VBScriptでフォントのインストーラーを作成する

VBScriptで作成した、フォントのインストーラーのサンプルを紹介します。

フォントは、フォントファイル(拡張子ttf)をC:\Windows\Fontsフォルダに配置し、さらにそのファイルパスをレジストリのHKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Fontsに書き込むことでインストールされます。
これには、Windowsシステムが持つフォントのインストーラーを実行するのがもっとも簡単です。
Windowsシステム上にて、フォントがインストールされているかどうかを判断は、フォントファイルがFontsフォルダに存在するかどうかではなく、レジストリに当該フォントの情報が書き込まれているかどうかで判断しています。

インストールするフォントがすでに対象となるパソコンにインストールされている場合、フォントのインストーラーはフォントの上書き確認をするメッセージを表示しますが、フォントのインストール時にいちいち確認メッセージが表示されてしまうのは少々わずらわしいため、ここで紹介するフォントのインストーラーでは、インストールしたいフォントがすでにインストールされている場合は、いったんアンインストールしてからインストールするようにしています。
'フォントをセットアップするためのスクリプトです。
'このスクリプトと同一ディレクトリに「FONT」フォルダを作成し、
'そのフォルダ内にインストールするフォントファイルを格納します。
Option Explicit

'----------------------------------------
' 定数定義
'----------------------------------------
'このスクリプトのタイトル
Const MY_TITLE = "FONT Setup"

Const SETUP_FONT_FOLDER_NAME = "FONT"               'インストールするフォントファイルが存在するフォルダ
Const SYSTEM_FONT_FOLDER_PATH = "C:\Windows\Fonts"  'フォントのインストール先フォルダの名前空間

'レジストリ関連
Const HKEY_LOCAL_MACHINE = &H80000002
Const REGKEY_PATH = "Software\Microsoft\Windows NT\CurrentVersion\Fonts"
Const REG_SZ = 1

'----------------------------------------
' 変数定義
'----------------------------------------
'FileSystemObjectインスタンス
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

'Shellインスタンス
Dim wShell
Set wShell = CreateObject("Shell.Application")

'----------------------------------------
' 処理
'----------------------------------------
'フォントをセットアップします
Call FontSetup

'********************************************************************************
' 概要 :フォントをセットアップします
' 引数 :なし
' 戻り値:なし
'********************************************************************************
Sub FontSetup()

  'インストールするフォントファイルが存在するフォルダのフォルダオブジェクトを取得します
  Dim fontDir
  Set fontDir = fso.GetFolder(MyDir & "\" & SETUP_FONT_FOLDER_NAME)

  'フォントのインストール先フォルダの名前空間オブジェクトを取得します
  Dim nsFontDir
  Set nsFontDir = wShell.Namespace(SYSTEM_FONT_FOLDER_PATH)

  'インストールするフォントファイルを1件ずつ処理します
  Dim fontFile
  For Each fontFile In fontDir.Files
    'すでにインストール済みのフォントなら、該当するフォントのレジストリを削除します(フォントの上書き確認を表示しないため)
    If (RemoveFont(fontFile.Name) = False) Then
      Exit Sub
    End If

    'エラーが発生しても処理を中断しません
    On Error Resume Next

    'フォントをインストールします
    nsFontDir.CopyHere fontFile.Path

    'エラー処理を通常どおりに戻します
    On Error GoTo 0

    'エラーが発生した場合は、エラーメッセージを表示して処理を抜けます
    If (Err.Number <> 0) Then
      Call ShowError("Font Copy:" & fontFile.Name)
      Exit Sub
    End If
  Next

  'インストール完了メッセージを表示します
  Call ShowInformation("Fontのインストールが完了しました。")

End Sub

'********************************************************************************
' 概要 :フォントファイル名に該当するフォントをレジストリから削除します
' 引数 :[fontFileName]...フォントファイル名
' 戻り値:正常に終了したらTrue、そうでなければFalse
'********************************************************************************
Function RemoveFont(ByVal fontFileName)

  '戻り値に初期値をセットします
  RemoveFont = False

  'ファイル名のベースを取得します(例:sample.ttf -> sample)
  Dim baseName
  baseName = fso.GetBaseName(fontFileName)

  'エラーが発生しても処理を中断しません
  On Error Resume Next

  '関連するフォントファイルをワイルドカード検索で削除します
  fso.DeleteFile SYSTEM_FONT_FOLDER_PATH & "\" & baseName & "*"

  'エラーが発生していた場合はエラーをクリアします(該当するファイルが存在しない場合はエラーを返すため)
  If (Err.Number <> 0) Then
    Err.Clear
  End If

  'エラー処理を通常どおりに戻します
  On Error GoTo 0

  'コンピューター名を指定します
  Dim compName
  compName = "."  'ローカルマシン

  '対象となるマシンのレジストリオブジェクトを取得します
  Dim reg
  Set reg = GetObject("winmgmts:\\" & compName & "\root\default:StdRegProv")

  'レジストリからフォントの一覧を取得します
  Dim valueNameList
  Dim valueTypeList
  reg.EnumValues HKEY_LOCAL_MACHINE, REGKEY_PATH, valueNameList, valueTypeList

  'レジストリから取得したフォント一覧より、フォント名に該当するフォントを削除します
  Dim i
  For i = 0 to UBound(valueNameList)
    'フォント名を取得します
    Dim valueName
    valueName = valueNameList(i)

    'レジストリの値が文字列データのみを対象とします
    Select Case valueTypeList(i)
      Case REG_SZ
        'レジストリから値を取得します
        Dim sValue
        reg.GetStringValue HKEY_LOCAL_MACHINE, REGKEY_PATH, valueName, sValue

        '値にフォントファイルのベース名が含まれている場合は、該当するレジストリを削除します
        If (0 < InStr(1, sValue, baseName)) Then
          reg.DeleteValue HKEY_LOCAL_MACHINE, REGKEY_PATH, valueName
        End If
    End Select
  Next

  RemoveFont = True
End Function

'********************************************************************************
' 概要 :このファイルが存在するディレクトリのフルパスを返します
' 引数 :なし
' 戻り値:このファイルが存在するディレクトリのフルパス
'********************************************************************************
Function MyDir()
  MyDir = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
End Function

'********************************************************************************
' 概要 :エラーメッセージを表示します
' 引数 :[caption]...エラーメッセージの見出し
' 戻り値:なし
'********************************************************************************
Sub ShowError(ByVal caption)
  Call MsgBox(CStr(Err.Number) & ":" & Err.Description, vbCritical + vbOkOnly, caption)
End Sub

'********************************************************************************
' 概要 :エラーメッセージを表示します
' 引数 :[caption]...エラーメッセージの見出し
' 戻り値:なし
'********************************************************************************
Sub ShowInformation(ByVal msg)
  Call MsgBox(msg, vbInformation + vbOkOnly, MY_TITLE)
End Sub