フォント変更のダイアログでは"OK"ボタンを押したからといって、対象となる文字列のフォントが変更されるわけではない。設定されたフォント情報を LOGFONT構造体 に格納してくれるだけなんだよね。従って、それ以降の処理は、使用用途に応じて自力で書かなきゃならない。VBにおいて、 LOGFONT構造体 のメンバ lfFaceName の扱い等、ややめんどくさい部分がある。

ここでのサンプルは、フォームのフォント情報を基盤にして、フォント変更のダイアログを表示するようにしてある。テキストボックスなどデバイスコンテキストを直接持たない(=プロパティとして提供されていないってこと)コントロールのフォントを変更するなら、デバイスコンテキストを持つダミーのコントロールを用意し、このフォントを基盤にする必要がある。この考え方、間違ってる？

Private Const LF_FACESIZE = 32

Private Type LOGFONT
    lfHeight As Long           '高さ
    lfWidth As Long            '幅
    lfEscapement As Long       '相対的出力角度(単位：1/10度)
    lfOrientation As Long      '回転角度(単位：1/10度)
    lfWeight As Long           '
    lfItalic As Byte           'イタリックが指定されたらChr$(1)、通常はChr$(0)
    lfUnderline As Byte        'アンダーラインが指定されたら１
    lfStrikeOut As Byte        '横線が指定されたら１
    lfCharSet As Byte          '
    lfOutPrecision As Byte     '常に０
    lfClipPrecision As Byte    '常に０
    lfQuality As Byte          '
    lfPitchAndFamily As Byte   '
    lfFaceName(LF_FACESIZE) As Byte     'フォント名
End Type

Private Type CHOOSEFONT
    lStructSize As Long        '構造体のサイズ
    hwndOwner As Long          'オーナーのハンドル
    hDC As Long                'デバイスコンテキストのハンドル
    lpLogFont As Long          'ダイアログを初期化するためのフォントの指定
    iPointSize As Long         'フォントサイズ(1/10 単位)
    flags As Long              'フラグ
    rgbColors As Long          'フォントカラー
    lCustData As Long          'カスタムダイアログへのデータ
    lpfnHook As Long           'フック関数へのポインタ
    lpTemplateName As String   'テンプレート名
    hInstance As Long          'テンプレートを持つモジュールのインスタンス
    lpszStyle As String        'フォントスタイル、フラグに CF_USESTYLE が指定されたときのみ有効
    nFontType As Integer       'フォントタイプ、(ZZZ_FONTTYPE)
    MISSING_ALIGNMENT As Integer   '???
    nSizeMin As Long           '選択可能な最小フォントサイズ
    nSizeMax As Long           '選択可能な最大フォントサイズ
End Type

'オブジェクトを取得する
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

'デバイスコンテキストから指定の種類のオブジェクトを取得する
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hDC As Long, ByVal uObjectType As Long) As Long

'[フォントの選択]ダイアログボックス
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long

Private Const OBJ_FONT = 6

'ChooseFont用
Private Const CF_SCREENFONTS = &H1                'システムでサポートされているスクリーンフォント
Private Const CF_PRINTERFONTS = &H2               'プリンタがサポートするフォント
Private Const CF_INITTOLOGFONTSTRUCT = &H40&      '
Private Const CF_EFFECTS = &H100&                 '取り消し線、下線、および色の設定を可能にする
Private Const CF_ANSIONLY = &H400&                'シングルフォントは表示しない
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_WYSIWYG = &H8000

'---------------------------------------------------------------------------
'  関数名： SetTextBoxFont
'   機能 ： フォントダイアログボックスを表示する
'   引数 ： なし
'  戻り値 ： 成功 ： １    キャンセルが押された ： ０
'---------------------------------------------------------------------------
Public Function ShowFontDlg(ByVal srcForm As Form)

    Dim ret As Long
    Dim udtLF As LOGFONT
    Dim udtCF As CHOOSEFONT
    Dim FontNameUNICODE As String
    Dim strFontName As String

    'フォームのフォント情報を取得する
    Call GetObject(GetCurrentObject(srcForm.hDC, OBJ_FONT), Len(udtLF), udtLF)

    With udtCF
        .lStructSize = Len(udtCF)
        .hwndOwner = srcForm.hWnd
        .hInstance = App.hInstance
        .lpLogFont = VarPtr(udtLF)
        .rgbColors = udtCF.rgbColors
        .flags = CF_BOTH Or CF_INITTOLOGFONTSTRUCT Or CF_EFFECTS 'Or CF_WYSIWYG
    End With

    'フォントを選択のダイアログボックスを表示
    ret = CHOOSEFONT(udtCF)

    If ret Then
        'フォント変更処理
        '            ・
        '            ・
        '  ここに処理を書いてね
        '            ・
        '            ・
        ShowFontDlg = 1
    Else
        'キャンセル
        ShowFontDlg = 0
    End If

End Function

さて、フォント変更処理なんだけどここは具体的には書かないよ。でも一応、簡単な処理について書いとくんで許してね。

取りあえず、フォントのハンドルを格納する変数 hFont とフォームのデフォルトのフォントハンドルを格納する変数 ObjfrmMainDefFont を外部変数として宣言しておく。後は、上の"ここに処理を書いてね"の部分に、以下の処理を書く。一応、テキストボックスのフォントを変更する処理だよ。API関数は自分で宣言してね、また hTextbox はテキストボックスのハンドルが格納されている外部変数だよ。

    'フォントが作成されているなら破棄
    If hFont Then Call DeleteObject(hFont)

    'フォームのデバイスコンテキストにデフォルトのフォントを戻す
    Call SelectObject(srcForm.hDC, ObjfrmMainDefFont)

    'フォント作成
    hFont = CreateFontIndirect(udtLF)

    If hFont Then
        'テキストボックスにフォントを設定する
        Call SendMessage(hTextbox, WM_SETFONT, hFont, ByVal 1&)

        'フォームに新しいフォントを割り当てる
        ObjfrmMainDefFont = SelectObject(srcForm.hDC, hFont)
    Else
        'エラー処理を書いてね
    End If

後は、Form_QueryUnload イベントに次のコードを書けばよろしい。

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    'フォームのデバイスコンテキストにデフォルトのフォントを戻す
    Call SelectObject(frmMain.hDC, ObjfrmMainDefFont)

    'フォントが作成されているなら破棄
    Call DeleteObject(hFont)

End Sub