ChooseFont

フォント選択ダイアログボックスを開く

Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _

        (lpcf As tagCHOOSEFONT) As Long

Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _

        (lpcf As tagCHOOSEFONT) As Integer

BOOL ChooseFont(
LPCHOOSEFONT lpcf
);
引数
lpcf

tagCHOOSEFONT構造体

OKボタンを押したとき                0以外
                                     tagCHOOSEFONT構造体に選択した値が戻る

キャンセル or クローズのとき	0

ダウンロード(ChooseFont.lzh 9.43KB)

Private Sub Command1_Click()
Dim lpcf As tagCHOOSEFONT
Dim lplf As LOGFONT
Dim hMem As Long, hGlobal As Long
Dim rc As Long

lplf.lfFaceName = String(LF_FACESIZE, Chr(0))
'LOGFONT構造体のポインタを取得する
hMem = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, Len(lplf))
If hMem = 0 Then
    MsgBox "LOGFONT構造体のメモリを確保できませんでした"
    Exit Sub
End If

hGlobal = GlobalLock(hMem)
'確保したメモリ領域にLOGFONT構造体をコピー
Call CopyMemory(ByVal hGlobal, lplf, Len(lplf))

'条件設定
With lpcf
    .lStructSize = Len(lpcf)
    .hwndOwner = Me.hWnd
    .hDC = 0
    .lpLogFont = hGlobal
    .iPointSize = 0
    .flags = CF_APPLY Or CF_EFFECTS Or CF_ENABLEHOOK Or _
            CF_SCREENFONTS Or CF_SHOWHELP Or CF_USESTYLE Or CF_LIMITSIZE
    .rgbColors = RGB(255, 0, 0)
    .lCustData = 0
    .lpfnHook = ChangeAddressOf(AddressOf DialogHookProc)
    .lpTemplateName = ""
    .hInstance = App.hInstance
    .lpszStyle = String(256, Chr(0))
    .nFontType = 8
    .MISSING_ALIGNMENT = 0
    .nSizeMin = 1
    .nSizeMax = 100
End With
'関数の実行
rc = ChooseFont(lpcf)

If rc = 1 Then
    Call CopyMemory(lplf, ByVal hGlobal, Len(lplf))
    
    Call GlobalUnlock(hGlobal)
    Call GlobalFree(hMem)
    
    MsgBox "フォント名：" + Mid(lplf.lfFaceName, 1, InStr(lplf.lfFaceName, Chr(0)) - 1) + _
         Chr(13) + Chr(10) + _
         "スタイル：" + Mid(lpcf.lpszStyle, 1, InStr(lpcf.lpszStyle, Chr(0)) - 1) + _
         Chr(13) + Chr(10) + _
         "フォントサイズ:" + Str(lpcf.iPointSize / 10) + Chr(13) + Chr(10) + _
         "フォントカラー：&H" + Hex(lpcf.rgbColors)
         
End If
End Sub