Question 92

Comment afficher la boîte de dialogue "ChooseFont" en utilisant les API ?

La procédure suivante affiche la boîte de dialogue "Choosefont". Etant donné que celle-ci renvoie non seulement une police mais aussi une couleur pour cette police, le retour se fait via les arguments que l'on passe dès lors par référence.

Option Explicit

' Déclarations des API
Private Declare Function ChooseFontDlg Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 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

' Constantes utilisées par ChooseFont
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_EFFECTS = &H100&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const FF_DONTCARE = 0

' Constantes utilisées par les API de mémoire
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40

' Constante utilisée par GetDeviceCaps
Private Const LOGPIXELSY = 90

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 * 31
End Type

Private 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 String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type

'---------------------------------------------------------------------------------------
' Sub :         ChooseFontDialog
' DateTime :    03/09/2002 15:19
' Auteur :      Pierre Alexis, François Picalausa, Allapi.net
' But :         Cette procédure affiche la boîte de dialogue "ChooseFont" et retourne
'               une police et une couleur
'---------------------------------------------------------------------------------------
Private Sub ChooseFontDialog(ByRef pFont As StdFont, Optional ByRef FontColor As Long = 0)

    Dim cf As CHOOSEFONT
    Dim lf As LOGFONT
    Dim hMem As Long, pMem As Long

    With lf
        .lfHeight = -(pFont.Size * GetDeviceCaps(Me.hdc, LOGPIXELSY)) / 72
        .lfEscapement = 0
        .lfOrientation = 0
        .lfWeight = pFont.Weight
        .lfItalic = pFont.Italic
        .lfUnderline = pFont.Underline
        .lfStrikeOut = pFont.Strikethrough
        .lfCharSet = pFont.Charset
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        .lfFaceName = pFont.Name & vbNullChar
    End With

    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lf))
    pMem = GlobalLock(hMem)
    CopyMemory ByVal pMem, lf, Len(lf)

    With cf
        .lStructSize = Len(cf)
        .hwndOwner = Me.hWnd
        .hdc = Printer.hdc
        .lpLogFont = pMem
        .flags = CF_BOTH Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT Or CF_FORCEFONTEXIST
        .rgbColors = FontColor
    End With

    If ChooseFontDlg(cf) <> 0 Then
        CopyMemory lf, ByVal pMem, Len(lf)
        pFont.Charset = lf.lfCharSet
        pFont.Italic = lf.lfItalic
        pFont.Name = Left$(lf.lfFaceName, InStr(lf.lfFaceName, Chr$(0)) - 1)
        pFont.Size = -(lf.lfHeight * 72) / GetDeviceCaps(Me.hdc, LOGPIXELSY)
        pFont.Strikethrough = lf.lfStrikeOut
        pFont.Underline = lf.lfUnderline
        pFont.Weight = lf.lfWeight
        FontColor = cf.rgbColors
    End If

    Call GlobalUnlock(hMem)
    Call GlobalFree(hMem)

End Sub

Private Sub Form_Click()

    Dim NewColor As Long

    NewColor = Me.ForeColor
    Call ChooseFontDialog(Me.Font, NewColor)
    Me.ForeColor = NewColor
    Me.Cls
    Me.Print "Petit test"

End Sub

Private Sub Form_Load()

    Me.ForeColor = RGB(0, 0, 255)
    Me.Caption = "Cliquez-moi !"
    Me.AutoRedraw = True
    Me.Print "Petit test"

End Sub

La documentation complète sur l'API ChooseFont se trouve sur la MSDN.