フォント選択ダイアログを開く          <TOP>


フォント選択ダイアログを開きます。

ChooseFont フォント選択のコモンダイアログボックスを表示

CopyMemory ある位置から別の位置にメモリブロックを移動

GlobalLock ヒープに確保されたメモリをロック

GlobalUnlock メモリブロックのロックを解除

GlobalAlloc メモリブロックを確保しハンドルを取得

GlobalFree メモリブロックのロックを解放

 

左上:初期状態    右:「フォント選択」ボタンクリックでダイアログ表示    左下:フォントを選択し「OK」クリックで選択フォントを表示

「摘要」「ヘルプ」ボタン、文字飾り、色、サイズ選択に表示されるサイズの制限などいろいろ設定が可能です。

 

 

'================================================================
'= フォント選択ダイアログの呼び出し
'=    (ChooseFont.bas)
'================================================================
#include "Windows.bi"

#define CCHDEVICENAME 32                'デバイス名の長さを示す定数
#define CCHFORMNAME 32                  'フォーム名の長さを示す定数
#define CF_APPLY &H200                  '「適用」ボタンを追加する
#define CF_BOTH (&H1 Or &H2)            'スクリーンフォント・するプリンタフォントを選択可能に
#define CF_EFFECTS &H100                '取り消し線付き、下線付き、文字色選択可能にする
#define CF_ENABLEHOOK &H8               'フックプロシージャを使う
#define CF_FORCEFONTEXIST &H10000       '存在しないフォントを選択しようとしたときにエラーとなる
#define CF_INITTOLOGFONTSTRUCT &H40     'LOGFONT構造体を使ってダイアログを初期化する
#define CF_LIMITSIZE &H2000             'フォントサイズの範囲を制限する
#define CF_PRINTERFONTS &H2             'プリンタで使えるフォントのみを表示
#define CF_SCREENFONTS &H1              'スクリーンフォントのみを選択可能に
#define CF_SHOWHELP &H4                 'ヘルプボタンを表示
#define CF_USESTYLE &H80                'lpszStyleメンバを使用
#define CLIP_DEFAULT_PRECIS 0           'クリッピング精度
#define DEFAULT_CHARSET 1               'デフォルトキャラクタセット
#define DEFAULT_PITCH 0                 'デフォルトのピッチ
#define DEFAULT_QUALITY 0               'デフォルト
#define DM_DUPLEX &H1000                '両面印刷
#define DM_ORIENTATION &H1              '
#define FF_ROMAN 16                     '可変ストローク幅を持つ、セリフ付きフォント
#define FW_NORMAL 400                   '
#define GMEM_MOVEABLE &H2               '
#define GMEM_ZEROINIT &H40              '
#define LF_FACESIZE 32                  '
#define OUT_DEFAULT_PRECIS 0            'デフォルト精度マッピング
#define REGUALR_FONTTYPE &H400          '標準体
#define SCRENN_FONTTYPE &H2000          'スクリーンフォント

Type LOGFONT
    lfHeight         As Long
    lfWidth          As Long
    lfEscapement     As Long
    lfOrientation    As Long
    lfWeight         As Long
    lfItalic         As Byte
    lfUnderline      As Byte
    lfStrikeOut      As Byte
    lfCharSet        As Byte
    lfOutPrecision   As Byte
    lfClipPrecision  As Byte
    lfQuality        As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * LF_FACESIZE
End Type

Type CHOOSEFONT
    lStructSize       As Long
    hwndOwner         As Long
    hDC               As Long
    lpLogFont         As Long
    iPointSize        As Long
    flags             As Long
    rgbColors         As Long
    lCustData         As Long
    lpfnHook          As Long
    lpTemplateName    As Long
    hInstance         As Long
    lpszStyle         As Long
    nFontType         As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin          As Long
    nSizeMax          As Long
End Type

' フォント選択のコモンダイアログボックスを表示
Declare Function Api_ChooseFont& Lib "comdlg32" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT)

' ある位置から別の位置にメモリブロックを移動する関数の宣言
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

' ヒープに確保されたメモリをロック
Declare Function Api_GlobalLock& Lib "kernel32" Alias "GlobalLock" (ByVal hMem&)

' メモリブロックのロックを解除
Declare Function Api_GlobalUnlock& Lib "kernel32" Alias "GlobalUnlock" (ByVal hMem&)

' メモリブロックを確保しハンドルを取得
Declare Function Api_GlobalAlloc& Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags&, ByVal dwBytes&)

' メモリブロックのロックを解放
Declare Function Api_GlobalFree& Lib "kernel32" Alias "GlobalFree" (ByVal hMem&)

Var Shared cf As CHOOSEFONT
Var Shared lf As LOGFONT

Var Shared Text1 As Object
Var Shared Button1 As Object

Text1.Attach GetDlgItem("Text1") : Text1.SetFontSize 14
Button1.Attach GetDlgItem("Button1") : Button1.SetFontSize 14

'================================================================
'=
'================================================================
Declare Function ShowFont() As String
Function ShowFont() As String
    Var hMem As Long
    Var pMem As Long
    Var Ret As Long

    lf.lfHeight = 13                                    'デフォルト高さ
    lf.lfWidth = 0                                      'デフォルト幅
    lf.lfEscapement = 0                                 'ベースラインと文字送りベクトルの間の角度
    lf.lfOrientation = 0                                'ベースラインとオリエンテーションベクトルの間の角度
    lf.lfWeight = FW_NORMAL                             '標準
    lf.lfCharSet = DEFAULT_CHARSET                      'デフォルトキャラクタセット
    lf.lfOutPrecision = OUT_DEFAULT_PRECIS              'デフォルト精度マッピング
    lf.lfClipPrecision = CLIP_DEFAULT_PRECIS            'デフォルトクリッピング精度
    lf.lfQuality = DEFAULT_QUALITY                      'デフォルト品質
    lf.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN     'デフォルトピッチ
    lf.lfFaceName = "MS ゴシック" & Chr$(0)           'デフォルト指定フォント名

    hMem = Api_GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lf))
    pMem = Api_GlobalLock(hMem)                         'ポインタを取得しロック
    CopyMemory ByVal pMem, lf, Len(lf)                  '構造体の内容をブロックにコピー

    cf.lStructSize = Len(cf)                            '構造体サイズ
    cf.hwndOwner = GethWnd                              'ダイアログボックスのウィンドウ
    cf.hDC = 0                                          'デフォルトプリンタのデバイスコンテキスト
    cf.lpLogFont = pMem                                 'LOGFONTメモリーブロックバッファへのポインタ
    cf.iPointSize = 100                                 '10 ポイントフォント(1/10 point)
    cf.flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
    cf.rgbColors = &H0	                                '黒 RGB(0, 0, 0)
    cf.lpTemplateName = 0
    cf.hInstance = GethInst                             'インスタンス
    cf.lpszStyle = StrAdr(String$(256, Chr$(0)))
    cf.nFontType = REGULAR_FONTTYPE                     'レギュラーフォントタイプ
    cf.MISSING_ALIGNMENT = 0
    cf.nSizeMin = 10                                    '最小ポイントサイズ
    cf.nSizeMax = 72                                    '最大ポイントサイズ

    Ret = Api_ChooseFont(cf)                            'ダイアログボックスを開く
    If Ret <> 0 Then                                    '成功
        CopyMemory lf, ByVal pMem, Len(lf)              'メモリコピー
        ShowFont = Left$(lf.lfFaceName, InStr(lf.lfFaceName, Chr$(0)) - 1)
    End If

    Ret = Api_GlobalUnlock(hMem)                        'ポインタの削除・ブロック解除
    Ret = Api_GlobalFree(hMem)                          '割り当てられたメモリをフリーに
End Function

'================================================================
'=
'================================================================
Declare Sub Button1_on edecl ()
Sub Button1_on()
    Var txt As String

    txt = ""
    txt = ShowFont & Chr$(13, 10)
    txt = txt & Str$(cf.iPointSize / 10) & "ポイント" & Chr$(13, 10)
    If lf.lfItalic Then
        txt = txt & "斜体:あり" & Chr$(13, 10)
    Else
        txt = txt & "斜体:なし" & Chr$(13, 10)
    End If
    If lf.lfUnderline Then
        txt = txt & "下線:あり" & Chr$(13, 10)
    Else
        txt = txt & "下線:なし" & Chr$(13, 10)
    End If
    If lf.lfWeight >= 700 Then
        txt = txt & "太字:あり" & Chr$(13, 10)
    Else
        txt = txt & "太字:なし" & Chr$(13, 10)
    End If
    If lf.lfStrikeOut Then
        txt = txt & "取り消し線:あり" & Chr$(13, 10)
    Else
        txt = txt & "取り消し線:なし" & Chr$(13, 10)
    End If
        txt = txt & "色:&&H" & Hex$(cf.rgbColors) & Chr$(13, 10)
    Text1.SetWindowText txt & "  が選択されました"
End Sub

'================================================================
'=
'================================================================
While 1
    WaitEvent
Wend
Stop
End