ホーム > カテゴリ > Visual Basic >

フォント選定ダイアログを表示する

フォント選定ダイアログを表示するサンプルです。

サンプルの実行画面

APIの宣言

[FontDlg.bas]

'----------------------------------------------------
'フォント選定のコモンダイアログボックスを表示するAPI関数
'----------------------------------------------------

 '<引数>    pChoosefont：PAPY(本当はCHOOSEFONT構造体、Type名を変更しないと使用できない）
 '<戻り値>　OKボタンを押した時0以外、キャンセルを押した時0

Public Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As PAPY) As Long


Public Type PAPY
  lStructSize As Long          '構造体のサイズ
  hwndOwner As Long            'ウインドウのハンドル
  hDC As Long                  'デバイスコンテキストのハンドル
  lpLogFont As Long            'ダイアログボックスを初期化する為のフォントの指定
  iPointSize As Long           'フォントのポイントサイズ
  flags As Long                'フラグ(定数CF_×××参照）
  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 '調整用（nFontType）
  nSizeMin As Long             '選択できる最小のファントサイズ
  nSizeMax As Long             '選択できる最大のフォントサイズ
End Type

Public Const CF_INITTOLOGFONTSTRUCT = &H40                 '初期化
Public Const CF_SCREENFONTS = &H1                          'スクリーンフォントのみ一覧に表示
Public Const CF_PRINTERFONTS = &H2                         'プリンタフォントのみ一覧に表示
Public Const CF_EFFECTS = &H100&                           '下線、横付き線、色を設定可能にする
Public Const CF_LIMITSIZE = &H2000&                        'nSizeMinとnSizeMaxでサイズだけを選択可能にする
Public Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) 'プリンタフォントとスクリーンフォントを表示

Public Const FW_NORMAL = 400           'ノーマル
Public Const FW_BOLD = 700             '太字
Public Const LF_FACESIZE = 32          '

Public Type LOGFONT
  lfHeight As Long                      '文字の高さ
  lfWidth As Long                       '文字の幅(0で標準)
  lfEscapement As Long                  '相対的出力角度
  lfOrientation As Long                 '回転角度
  lfWeight As Long                      '文字の太さ(定数FW_×××参照)
  lfItalic As Byte                      '斜体 Chr$(1)、通常 Chr$(0)
  lfUnderline As Byte                   '下線 1
  lfStrikeOut As Byte                   '取り消し線 1
  lfCharSet As Byte                     '文字セットの指定
  lfOutPrecision As Byte                '常に0
  lfClipPrecision As Byte               '常に0
  lfQuality As Byte                     '
  lfPitchAndFamily As Byte              '
  lfFaceName As String * LF_FACESIZE    'フォント名
End Type
 
 
'----------------------------------------------
'メモリブロックを確保してそのハンドルを返すAPI関数
'----------------------------------------------
  
  'wFlags：定数（GHND_××参照）
  'dwBytes：確保するバイト数
  '戻り値：メモリブロックのハンドル

Public Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
     
Public Const GMEM_MOVEABLE = &H2                      '利用可能なメモリを確保
Public Const GMEM_ZEROINIT = &H40                     '新しく確保するメモリブロックの内容を0で初期化
Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)


'-------------------------------------
'メモリブロックのロックを解放するAPI関数
'-------------------------------------
  
  'hMem：メモリブロックのハンドル
  '戻り値：正常終了0

Public Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
      
'---------------------------------------------------------
'グローバルヒープに確保されたメモリブロックをロックするAPI関数
'---------------------------------------------------------

  'hMem:GlobalAllocで戻ったハンドル
  '戻り値：メモリブロックの先頭を示すアドレス
   
Public Declare Function GlobalLock Lib "KERNEL32" (ByVal hMem As Long) As Long
    
'-------------------------------------
'メモリブロックのロックを解除するAPI関数
'-------------------------------------
  
  'hMem:グローバルメモリブロックのハンドル
  '戻り値：解除された時0

 Public Declare Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As Long) As Long
      
'---------------------------------
'メモリの指定領域をコピーするAPI関数
'---------------------------------
 
  'Dest:コピー先のポインタ
  'Source:コピー元のポインタ
  'length:コピーするバイト数
  '戻り値：なし

Public Declare Sub MoveMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal length As Long)

'------------
'使用する変数
'------------

Public nFontName As String           'フォントの名前
Public nFontSize As Long             'フォントのサイズ
Public nFontBold As Boolean          'フォントの太字
Public nFontItalic As Boolean        'フォントの斜体
Public nFontStrikethrough As Boolean 'フォントの取り消し線
Public nFontUnderline As Boolean     'フォント の下線
Public nColor As Long                'フォントのカラー値
 
'-------------------------------------------------------------------------------
'■関数名   FontDlg
'■用途　　 フォント選定のコモンダイアログボックスを表示して選択した各種情報を取得する
'■引数
'   nHwnd               :ウインドウのハンドル
'   FontName            :フォント名
'   FontColor           :フォントのカラー値
'   FontSize            :フォントのサイズ
'   FontBold            :フォントに太字が付加されているか
'   FontItalic          :フォントに斜体が付加されているのか
'   FontStrikethrough   :フォントに取り消し線が付加されているか
'   FontUnderline       :フォントに下線が付加されているか
'
'■戻り値　 OKボタンを押した時0,キャンセルボタンを押した時1
'-------------------------------------------------------------------------------

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       'PAPY構造体
   Dim LF As LOGFONT        'LOGFONT構造体
   Dim Address As Long      'ポインタ
   Dim hMem As Long         '戻り値（メモリブロックのハンドル）
   Dim mRet As Long         '戻り値（GlobalUnlock、GlobalFreeで使用）
   Dim Ret As Long          '戻り値（CHOOSEFONTで使用）
   
   
   'LOGFONT構造体の設定
   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))
   
    'PAPY構造体の設定
    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)
       'フォントの幅情報を取得（lfWeightの値はTrue,Falseではないので注意）
       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

APIの呼び出し

[FontDlg.frm]

Private Sub Command1_Click()
 
 Dim Ret As Long
   
  '現在のフォント情報を取得
    Ret = FontDlg(hWnd, Font.Name, ForeColor, _
                  Font.Size, Font.Bold, Font.Italic, _
                  Font.Strikethrough, Font.Underline)
      
  If Ret = 0 Then
    
     '文字を出力
        With Label1
           .Caption = vbCrLf & "VisualBasic"
           .FontBold = nFontBold
           .FontItalic = nFontItalic
           .Font.Name = nFontName
           .FontSize = nFontSize
           .FontStrikethru = nFontStrikethrough
           .FontUnderline = nFontUnderline
           .ForeColor = nColor
       End With
        
       List1.Clear
       
      'フォント情報を出力
       With List1
        .AddItem "フォント名 " & vbTab & nFontName
        .AddItem "サイズ " & vbTab & vbTab & nFontSize
        .AddItem "太字 " & vbTab & vbTab & nFontBold
        .AddItem "斜体 " & vbTab & vbTab & nFontItalic
        .AddItem "下線 " & vbTab & vbTab & nFontUnderline
        .AddItem "取り消し線 " & vbTab & nFontStrikethrough
        .AddItem "カラー値 " & vbTab & vbTab & "#" & Hex(nColor)
       End With
        
  End If
    
End Sub

Private Sub Form_Load()
  
 '初期設定
  
  With Label1
    .Caption = ""
    .Alignment = 2
    .BorderStyle = 1
  End With
  
  With List1
   .AddItem "フォント名 " & vbTab & Font.Name
   .AddItem "サイズ " & vbTab & vbTab & Font.Size
   .AddItem "太字 " & vbTab & vbTab & Font.Bold
   .AddItem "斜体 " & vbTab & vbTab & Font.Italic
   .AddItem "下線 " & vbTab & vbTab & Font.Underline
   .AddItem "取り消し線 " & vbTab & Font.Strikethrough
   .AddItem "カラー値 " & vbTab & vbTab & "#" & Hex(ForeColor)
  End With

End Sub

ソースコード一式のダウンロード

vbapi_fontdlg.zip 4.39 KB (4,501 バイト)

このサンプルの動作環境について

このサンプルは 「Windows98」及び「Microsoft Visual Basic 5.0 Professional Edition」で確認しております。環境が異なる場合は正常に動作しない場合もございますのでご了承下さい。





関連記事


前の記事：「フォルダを選択」ダイアログを表示する
次の記事：ヘルプファイルを表示する

公開日：2015年03月03日
記事NO：00322