Discussion :

[NEC14]

Bonjour,

Tout est dit dans l'intitulé. Je cherche à modifier la police du titre de mon UF, est-ce possible et comment ?
Merci pour votre aide

[mercatog]

Bonjour
A force de se pencher sur les apparences, on oublie vite la fonctionnalité essentielle d'Excel. En quoi change un titre d'un userform en noir ou en bleu?

La demande directement n'est pas possible; néanmoins en utilisant les API avec une usine à gaz (d'où la pensée précédente) on peut agir sur les barre de l'userform.

Dans un module standrad (Jugez vous même)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
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 * 32
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lgParam As Any) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lgParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lgParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function BeginPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const RDW_INTERNALPAINT As Long = &H2
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CYCAPTION As Long = 4
Private tPoint As POINTAPI
Private tRect As RECT
Private lgPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private strTitre As String
Private lgCaptionColour As Long
Private lgTaillePolice As Long
Private lgCouleurPolice As Long
Private bGras As Boolean
Private bItalique As Boolean
Private strPolice As String
 
Private Sub Terminer()
 
UnhookWindowsHookEx lhHook
bHookEnabled = False
End Sub
 
Private Function Traitement(ByVal idHook As Long, ByVal wParam As Long, ByVal lgParam As Long) As Long
Dim strBuffer As String
Dim lgRetour As Long
 
If idHook = HCBT_ACTIVATE Then
    strBuffer = Space(256)
    lgRetour = GetClassName(wParam, strBuffer, 256)
    If Left(strBuffer, lgRetour) = "ThunderDFrame" Or Left(strBuffer, lgRetour) = "ThunderXFrame" Then
        lgPrevWnd = SetWindowLong(wParam, GWL_WNDPROC, AddressOf Appeler)
        Call Terminer
    End If
 
End If
Traitement = CallNextHookEx(lhHook, idHook, ByVal wParam, ByVal lgParam)
End Function
 
Private Function Appeler(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lgParam As Long) As Long
Dim lgDC As Long
 
On Error Resume Next
'get current userform position.
GetWindowRect hwnd, tRect
Select Case Msg
    Case WM_PAINT, WM_ACTIVATE
        If Msg = WM_ACTIVATE Then Call DeplacerCurseur
        lgDC = GetWindowDC(hwnd)
        Call RetracerBarre(hwnd, lgCaptionColour)
        SetBkMode lgDC, 1
        SetTextColor lgDC, lgCouleurPolice
        AdapterPolice lgDC, Gras:=bGras, Italique:=bItalique
        TextOut lgDC, 6, GetSystemMetrics(SM_CYCAPTION) / 3, strTitre, Len(strTitre)
        ReleaseDC hwnd, lgDC
        InvalidateRect hwnd, 0, 0
    Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
        If Msg = WM_SHOWWINDOW Then SetCursorPos tPoint.x, tPoint.y
        SendMessage hwnd, WM_PAINT, 0, 0
        Call DeplacerCurseur
    Case WM_DESTROY
        SetWindowLong hwnd, GWL_WNDPROC, lgPrevWnd
End Select
 
Appeler = CallWindowProc(lgPrevWnd, hwnd, Msg, wParam, ByVal lgParam)
End Function
 
Private Sub AdapterPolice(lgDC As Long, Optional Gras As Boolean, Optional Italique As Boolean)
Dim uPolice As LOGFONT
Dim lgNewPolice As Long
 
With uPolice
    .lfFaceName = strPolice & Chr$(0)
    .lfHeight = lgTaillePolice
    .lfWidth = 8
    .lfWeight = IIf(Gras, 900, 100)
    .lfItalic = IIf(Italique, 1, 0)
End With
 
lgNewPolice = CreateFontIndirect(uPolice)
DeleteObject (SelectObject(lgDC, lgNewPolice))
End Sub
 
Private Sub RetracerBarre(lghwnd As Long, Color)
Dim lgDC As Long, hBrush As Long
Dim tPS As PAINTSTRUCT
Dim tLB As LOGBRUSH
Dim tR As RECT
 
BeginPaint lghwnd, tPS
lgDC = GetWindowDC(lghwnd)
tLB.lbColor = Color
hBrush = CreateBrushIndirect(tLB)
SetRect tR, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)
FillRect lgDC, tR, hBrush
Call DeleteObject(hBrush)
RedrawWindow lghwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
DeleteDC lgDC
Call EndPaint(lghwnd, tPS)
End Sub
 
Private Sub TracerCroix()
 
DoEvents
SetCursorPos tPoint.x, tPoint.y
End Sub
 
Private Sub DeplacerCurseur()
 
GetCursorPos tPoint
SetCursorPos tRect.Right - 15, tRect.Top + 15
Application.OnTime Now + TimeSerial(0, 0, 0.1), "TracerCroix"
End Sub
 
Sub Adapter(ByVal USF, ByVal Police As String, ByVal CouleurBarre, ByVal CouleurPolice, ByVal Taille, ByVal Gras, ByVal Italique)
 
If Not bHookEnabled Then
    Set oForm = USF
    strTitre = USF.Caption
    strPolice = Police
    lgCaptionColour = CouleurBarre
    lgCouleurPolice = CouleurPolice
    lgTaillePolice = Taille
    bGras = Gras
    bItalique = Italique
    lhHook = SetWindowsHookEx(WH_CBT, AddressOf Traitement, 0, GetCurrentThreadId)
    bHookEnabled = True
    USF.Show
End If
End Sub

Ensuite on affiche l'userform avec cette ligne (en adaptant les paramètres)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Sub Test()
 
Call Adapter(USF:=UserForm1, Police:="Century Gothic", CouleurBarre:=vbBlack, CouleurPolice:=vbRed, Taille:=18, Gras:=True, Italique:=True)
End Sub

PS. Procédure trouvée sur le net et adapté à ton cas.

Personnellement, je n'utilise pas de telles usines à gaz.

[NEC14]

Bonjour mercatog,

Merci beaucoup pour ce travail. Effectivement, beaucoup de ligne pour pas grand chose au final. Tu as soulevé la question de savoir si cela valait la peine de faire une usine à gaz, je ne le crois pas.

Un grand merci pour ton investissement.
René