'フォントコモンダイアローグ
'------------- AccessでのＣａｌｌ例 ---------------------------------------------------
Private Sub フォント_Click()
    cf_hWndParent = Me.hWnd
    'CF_BOTHを設定しないとだめみたいです
    cf_lngFlags = CF_BOTH Or CF_APPLY Or CF_EFFECTS
    With Me!ラベル0
        cf_strFontName = .FontName
        cf_lngFontSize = .FontSize
        cf_bolFontBold = IIf(.FontWeight = FW_BOLD, True, False)
        cf_bolFontItalic = .FontItalic
        cf_bolFontUnderline = .FontUnderline
        cf_lngColor = .ForeColor
    End With
    
    ChooseFontDlg
    
    If Err = 0 Then
        With Me!ラベル0
            .FontName = cf_strFontName
            .FontSize = cf_lngFontSize
            .FontWeight = IIf(cf_bolFontBold, FW_BOLD, FW_NORMAL)
            .FontItalic = cf_bolFontItalic
            .FontUnderline = cf_bolFontUnderline
            .ForeColor = cf_lngColor
        End With
    End If
End Sub
'------------- AccessでのＣａｌｌ例 ----- END ----------------------------------------------

'------------- 以下 標準モジュール ---------------------------------------------------------
Option Compare Database
Option Explicit

'ChooseFont API関数の定数
Public Const CF_APPLY = &H200               '「適用」ﾎﾞﾀﾝを追加（[OK]ﾎﾞﾀﾝを使用可能にする）
Public Const CF_ANSIONLY = &H400            'ｼﾝﾎﾞﾙﾌｫﾝﾄは表示しない
Public Const CF_TTONLY = &H40000            'TrueType フォントのみ表示
Public Const CF_EFFECTS = &H100             '取消線付き、下線付き、文字色選択可能にする
Public Const CF_ENABLEHOOK = &H8            'フック関数を使う
Public Const CF_ENABLETEMPLATE = &H10       'テンプレートを使う
Public Const CF_ENABLETEMPLATEHANDLE = &H20 'テンプレートを使う
Public Const CF_FIXEDPITCHONLY = &H4000&    '固定ピッチフォントのみ選択可能
Public Const CF_FORCEFONTEXIST = &H10000    '存在しないフォントを選択しようとしたときエラーにする
Public Const CF_INITTOLOGFONTSTRUCT = &H40  'LOGFONT 構造体を使ってダイアログを初期化する
Public Const CF_LIMITSIZE = &H2000&         'フォントサイズの範囲を制限する
Public Const CF_NOFACESEL = &H80000         'ﾌｫﾝﾄ名が選択されていない
Public Const CF_NOSCRIPTSEL = &H800000      '「書体の種類」を無効にする
Public Const CF_NOSTYLESEL = &H100000       'ﾌｫﾝﾄ ｽﾀｲﾙが選択されていない
Public Const CF_NOSIZESEL = &H200000        'ﾌｫﾝﾄ ｻｲｽﾞが選択されていない
Public Const CF_NOSIMULATIONS = &H1000&     'シミュレートフォントを使用できない
Public Const CF_NOVECTORFONTS = &H800       'ﾍﾞｸﾀ ﾌｫﾝﾄを選択できない
Public Const CF_NOVERTFONTS = &H1000000     '縦書きフォントを表示しない
Public Const CF_PRINTERFONTS = &H2          'プリンタで使えるフォントのみを表示
Public Const CF_SCALABLEONLY = &H20000      'スケーラブルフォントのみを選択可能にする
Public Const CF_SCREENFONTS = &H1           'スクリーンフォントのみを選択可能にする
Public Const CF_SCRIPTSONLY = CF_ANSIONLY   'ｼﾝﾎﾞﾙﾌｫﾝﾄは表示しない
Public Const CF_SELECTSCRIPT = &H400000     '
Public Const CF_SHOWHELP = &H4              'ヘルプボタンを表示する
Public Const CF_USESTYLE = &H80             'lpszStyle メンバを使用する
Public Const CF_WYSIWYG = &H8000&           'ディスプレイとプリンタの両方で使えるフォントのみを選択可能にする
Public Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) 'ﾌﾟﾘﾝﾀﾌｫﾝﾄとｽｸﾘｰﾝﾌｫﾝﾄを表示
Public Const CF_NOOEMFONTS = CF_NOVECTORFONTS   'ﾍﾞｸﾀ ﾌｫﾝﾄを選択できない

Public cf_hWndParent As Long
Public cf_strFontName As String
Public cf_lngFontSize As Long
Public cf_bolFontBold As Boolean
Public cf_bolFontItalic As Boolean
Public cf_bolFontStrikeOut As Boolean
Public cf_bolFontUnderline As Boolean
Public cf_lngMax As Long
Public cf_lngMin As Long
Public cf_lngColor As Long
Public cf_lngFlags As Long

'LogFontの構造体
Const LF_FACESIZE = 32
Public Const FW_NORMAL = 400 'NORMALﾌｫﾝﾄの Weight
Public Const FW_BOLD = 700   'BOLDﾌｫﾝﾄの Weight
Private 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

'ChooseFontの構造体
Private Type tagCHOOSEFONT
    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 String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type

'フォント選択ダイアログボックス表示
Private Declare Function ChooseFont Lib "COMDLG32" Alias "ChooseFontA" (pChoosefont As tagCHOOSEFONT) As Long
'コモンダイアログボックスからのエラーメッセージ取得
Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long

'デバイスコンテキストのハンドル取得
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long

'デバイス情報取得
'nIndexに指定する1論理ｲﾝﾁあたりのﾋﾟｸｾﾙ数を求める定数
Const LOGPIXELSX = 88 '横方向
Const LOGPIXELSY = 90 '縦方向
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

'メモリブロックを確保
Const GMEM_MOVEABLE = &H2  '移動可能なメモリを確保
Const GMEM_ZEROINIT = &H40 '確保するメモリブロックを０で初期化
Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

'メモリブロックを開放
Private Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
'メモリブロックをロック
Private Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long
'メモリブロックのロックを解除
Private Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long
'メモリブロックをコピー
Private Declare Sub CopyMemoryLong Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long)
'メモリブロックをコピー
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'ﾌｫﾝﾄ選択ﾀﾞｲｱﾛｸﾞの表示
'正常終了の場合Trueを返す
Public Function ChooseFontDlg() As Long
    Dim lngRtn As Long
    Dim lngPixelY As Long
    Dim LF As LOGFONT
    Dim CF As tagCHOOSEFONT
    Dim SizeOfLogFont As Long
    Dim AddressOfLF As Long
    Dim hMemory As Long
    Dim i As Integer
    On Error GoTo errChooseFontDlg

    'ﾃﾞｨｽﾌﾟﾚｲの解像度
    lngPixelY = GetDeviceCaps(GetDC(0), LOGPIXELSY)
    'ﾋﾟｸｾﾙに変換
    LF.lfHeight = cf_lngFontSize * lngPixelY / 72
    
    LF.lfWeight = IIf(cf_bolFontBold, FW_BOLD, FW_NORMAL)
    If cf_bolFontItalic = True Then LF.lfItalic = 1
    If cf_bolFontUnderline = True Then LF.lfUnderline = 1
    If cf_bolFontStrikeOut = True Then LF.lfStrikeOut = 1
    
    'vbNullChar=Chr(0)を付加する
    LF.lfFaceName = cf_strFontName & vbNullChar
    
    'LOGFONT構造体のｻｲｽﾞ
    SizeOfLogFont = Len(LF)
    
    CF.lStructSize = SizeOfLogFont
    CF.hwndOwner = cf_hWndParent
    
    'LOGFONT構造体のｻｲｽﾞのﾒﾓﾘ領域を確保
    hMemory = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, SizeOfLogFont)
    
    If hMemory = 0 Then Exit Function
    
    'ﾒﾓﾘ領域ﾛｯｸ
    AddressOfLF = GlobalLock(hMemory)
    If AddressOfLF = 0 Then Exit Function
    
    'ﾒﾓﾘ領域に LOGFONT の内容をｺﾋﾟｰ
    Call CopyMemoryLong(AddressOfLF, LF, SizeOfLogFont)
    
    CF.lpLogFont = AddressOfLF
    CF.iPointSize = cf_lngFontSize * 10
    
    'LOGFONT でﾀﾞｲｱﾛｸﾞを初期化
    CF.flags = cf_lngFlags Or CF_INITTOLOGFONTSTRUCT
    
    CF.rgbColors = cf_lngColor
    CF.nSizeMin = cf_lngMin
    CF.nSizeMax = cf_lngMax
    
    lngRtn = ChooseFont(CF)
    
    Select Case lngRtn
    Case 0 'ｷｬﾝｾﾙ
    Case 1 'OK
        'ChooseFont が設定したﾒﾓﾘ領域の内容を LOGFONT にｺﾋﾟｰ
        Call CopyMemory(LF, ByVal AddressOfLF, SizeOfLogFont)
        
        '（選択の結果）
        cf_strFontName = NullCharCut(LF.lfFaceName)
        cf_lngFontSize = CF.iPointSize / 10
        cf_bolFontBold = IIf((LF.lfWeight >= FW_BOLD), True, False)
        cf_bolFontItalic = IIf(LF.lfItalic, True, False)
        cf_bolFontUnderline = IIf(LF.lfUnderline, True, False)
        cf_bolFontStrikeOut = IIf(LF.lfStrikeOut, True, False)
        cf_lngColor = CF.rgbColors
        ChooseFontDlg = True
    Case Else 'ｴﾗｰ
        ChooseFontDlg = CommDlgExtendedError()
    End Select
errChooseFontDlg:
    lngRtn = GlobalUnlock(hMemory)
    lngRtn = GlobalFree(hMemory)
    Resume Next
End Function

Function NullCharCut(ByVal strExp As String) As String
    'vbNullChar以降を削除
    Dim i As Integer
    
    i = InStr(strExp, vbNullChar)
    If i Then strExp = Left$(strExp, i - 1)
    NullCharCut = strExp
End Function