フォント選択ダイアログを開く <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 = "ＭＳ ゴシック" & 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