1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
| Option Compare Database
Option Explicit
Public Type Police
Nom As String
Taille As Long
Souligne As Boolean
Italique As Boolean
Gras As Boolean
Barre As Boolean
Couleur As Long
End Type
Const LOGPIXELSY = 90
Const FW_NORMAL = 400
Const FW_GRAS = 700
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const CF_NOSCRIPTSEL = &H800000
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
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
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 Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) 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
Public Function ChoisirPolice(Handle As Long, PoliceParDefaut As Police) As Police
Dim Boite As CHOOSEFONT, LaPolice As LOGFONT, hMem As Long, pMem As Long
Dim resultat As Long, Retour As Police
'*****************************************
'definit la police par defaut à afficher
LaPolice.lfStrikeOut = PoliceParDefaut.Barre
LaPolice.lfWeight = IIf(PoliceParDefaut.Gras, FW_GRAS, FW_NORMAL)
LaPolice.lfItalic = PoliceParDefaut.Italique
LaPolice.lfUnderline = PoliceParDefaut.Souligne
LaPolice.lfHeight = -PoliceParDefaut.Taille * GetDeviceCaps(GetDC(Handle), LOGPIXELSY) / 72
If PoliceParDefaut.Nom = "" Then PoliceParDefaut.Nom = "Tahoma"
LaPolice.lfFaceName = PoliceParDefaut.Nom & vbNullChar 'Nom de la police par defaut
'******************************************
' Creer une structure LOGFont en memoire.
hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(LaPolice))
'Verouille et recupere le pointeur vers la structure
pMem = GlobalLock(hMem)
'Copie la structure
CopyMemory ByVal pMem, LaPolice, Len(LaPolice)
'Initialise la boite de dialogue
Boite.lStructSize = Len(Boite)
Boite.hwndOwner = Handle
'Affecte la police par defaut
Boite.lpLogFont = pMem
'defini la taille (10*La taille de la police)
Boite.iPointSize = 120 'PoliceParDefaut.Taille * 10
'Personalise la boite
Boite.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or _
CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE Or _
CF_NOSCRIPTSEL
'Fixe la couleur
Boite.rgbColors = PoliceParDefaut.Couleur
Boite.nFontType = REGULAR_FONTTYPE
'Definit les tailles possibles
Boite.nSizeMin = 6
Boite.nSizeMax = 72
'Ouvre la boite
resultat = CHOOSEFONT(Boite)
If resultat <> 0 Then
CopyMemory LaPolice, ByVal pMem, Len(LaPolice)
'Prepare le resultat
Retour.Nom = Left(LaPolice.lfFaceName, InStr(LaPolice.lfFaceName, vbNullChar) - 1)
'Inscrit dans la table des paramêtre le nom de la police
SetGlobal "NomPolice", Retour.Nom
Retour.Taille = Boite.iPointSize \ 10
'Inscrit dans la table des paramêtre la taille de la police
SetGlobal "TaillePolice", Retour.Taille
Retour.Couleur = Boite.rgbColors
'Inscrit dans la table des paramêtre la couleur de la police
SetGlobal "CouleurPolice", Retour.Couleur
Retour.Gras = LaPolice.lfWeight > FW_NORMAL
'Inscrit dans la table des paramêtre le gras de la police
SetGlobal "GrasPolice", Retour.Gras
Retour.Italique = LaPolice.lfItalic
'Inscrit dans la table des paramêtre l'italique de la police
SetGlobal "ItaliquePolice", Retour.Italique
Retour.Souligne = LaPolice.lfUnderline
'Inscrit dans la table des paramêtre le souligné de la police
SetGlobal "SoulignePolice", Retour.Souligne
Retour.Barre = LaPolice.lfStrikeOut
'Inscrit dans la table des paramêtre le barré de la police
SetGlobal "BarrePolice", Retour.Barre
End If
'libere la memoire
resultat = GlobalUnlock(hMem)
resultat = GlobalFree(hMem)
ChoisirPolice = Retour
End Function |
Comment maintenir une police après l'avoir enregistrée ?
Répondre avec citation
Envoyé par morobaboumar
Partager