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. |