１０１．フォント選定のコモンダイアログボックスを表示する

＜　使用用途　＞
OCX等使わないでこれを使いましょう

今回のサンプルソースをダウンロードする方は下記の「ダウンロード」を！
＝＞　ダウンロード・・・　説明を大量に書きこんでいます

　＜　説明　＞
ＡＰＩ関数のCHOOSEFONTを使用します
CHOOSEFONT ＝＞コモンダイアログを表示
　　＜引数＞
　　　　　 pChoosefont：CHOOSEFONT構造体　　　　　　　
　　＠戻り値＠
　　　　　 OKボタンを押した時0以外、キャンセルボタンを押した時0

<　ＳＡＭＰＬＥ　＞
’ここでは関数だけを掲載します（すべて掲載すると長くなるので・・・）
'-------------------------------------------------------------------------------
'■関数名 FontDlg
'■用途　　 フォント選定のコモンダイアログボックスを表示して選択した各種情報を取得する
'■引数
' nHwnd :ウインドウのハンドル
' FontName :フォント名
' FontColor :フォントのカラー値
' FontSize :フォントのサイズ
' FontBold :フォントに太字が付加されているか
' FontItalic :フォントに斜体が付加されているのか
' FontStrikethrough :フォントに取り消し線が付加されているか
' FontUnderline :フォントに下線が付加されているか
'
'■戻り値　 OKボタンを押した時1,キャンセルボタンを押した時0
'-------------------------------------------------------------------------------

Public Function FontDlg(nHwnd As Long, _
　　　　　　　　　　　　　　　FontName As String, _
　　　　　　　　　　　　　　　FontColor As Long, _
　　　　　　　　　　　　　　　FontSize As Long, _
　　　　　　　　　　　　　　　FontBold As Boolean, _
　　　　　　　　　　　　　　　FontItalic As Boolean, _
　　　　　　　　　　　　　　　FontStrikethrough As Boolean, _
　　　　　　　　　　　　　　　FontUnderline As Boolean _
　　　　　　　　　　　　　　) As Long

　　Dim nFonts As PAPY
　　Dim LF As LOGFONT
　 Dim Address As Long
　　Dim hMem As Long
　　Dim mRet As Long
　　Dim Ret As Long
　　With LF
　　　.lfFaceName = FontName & Chr(0)
　　　.lfHeight = FontSize / 0.75
　　　.lfItalic = FontItalic
　　　.lfUnderline = FontUnderline
　　　.lfStrikeOut = FontStrikethrough
　　　.lfWeight = FontBold
　　 End With

　　
　　 hMem = GlobalAlloc(GHND, Len(LF))
　　
　　Address = GlobalLock(hMem)
　　
　　Call MoveMemory(ByVal Address, LF, Len(LF))

　　
　　With nFonts
　　　.lStructSize = Len(nFonts)
　　　 .hwndOwner = nHwnd
　　　 .lpLogFont = Address
　　　.flags = CF_INITTOLOGFONTSTRUCT Or _
　　　　　　　　 CF_SCREENFONTS Or _
　　　　　　　　CF_LIMITSIZE Or _
　　　　　　　　CF_EFFECTS
　　　 .rgbColors = ForeColor
　　　 .nSizeMin = 8
　　　 .nSizeMax = 24
　　End With

　　
　　Ret = CHOOSEFONT(nFonts)
　　
　　 Call MoveMemory(LF, ByVal Address, Len(LF))
　　
　　 mRet = GlobalUnlock(hMem)
　　
　　 mRet = GlobalFree(hMem)


　　If Ret <> 0 Then

　　　
　　　 nFontName = Left(LF.lfFaceName, InStr(LF.lfFaceName, Chr(0)) - 1)
　　　
　　　nFontBold = IIf(LF.lfWeight = FW_NORMAL, False, True)
　　　
　　　nFontItalic = LF.lfItalic
　　　
　　　nFontStrikethrough = LF.lfStrikeOut
　　　
　　　nFontUnderline = LF.lfUnderline
　　　
　　　nFontSize = Abs(LF.lfHeight * 0.75)
　　　
　　　nColor = nFonts.rgbColors

　　 Else
　　　
　　　FontDlg = 1

　　 End If

End Function