Bonjour à tous,

Voici ma petite participation du jour.
Tout est dit dans le titre.

J'ai parfois un souci avec la touche Entrée sur le TextBox.
C'est exactement comme si on ne parvenait pas à donner le focus au TextBox.
Du coup, l'userform ne se "hide" plus.
La touche Echap fonctionne mieux, semble-t'il.
Je ne parviens pas à l'expliquer...

ATTENTION :
Dans les options d'Excel, il faut avoir coché "Accès approuvé au modèle d'objet du projet VBA".
Pour cela, voir dans Options>Centre de gestion de la confidentialité>Paramètres des macros.

Le code nécessite également de cocher la référence : Microsoft Forms 2.0 Object Library


Un module de classe nommé "clUsfTB" :
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
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
Option Explicit
 
'Dans les options d'Excel, il faut avoir coché "Accès approuvé au modèle d'objet du projet VBA".
'Pour cela, voir dans Options>Centre de gestion de la confidentialité>Paramètres des macros.
 
'Le code nécessite également de cocher la référence :
    'Microsoft Forms 2.0 Object Library
 
'____ENUMERATIONS____
Private Enum BOOL
    FALSE_
    TRUE_
End Enum
 
'____TYPES____
Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom 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 * 32 '
End Type
 
Private Type hv
    X As Long
    Y As Long
End Type
 
'____DECLARATIONS FONCTIONS API____
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" _
            (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" _
            (ByVal hwnd As LongPtr, lpRect As Rect) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" _
            (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, _
            ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" _
            (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" _
            (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DwmIsCompositionEnabled Lib "dwmapi.dll" _
            (ByRef pfEnabled As BOOL) As Long
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
            (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
            (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
            (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
            (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
#Else
    Private Declare Function FindWindowA Lib "user32" _
            (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" _
            (ByVal hwnd As Long, lpRect As Rect) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias _
            "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 SetWindowPos Lib "user32" _
            (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
            ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" _
            (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" _
            (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" _
            (ByRef pfEnabled As BOOL) As Long
#End If
'Utiles pour la fonction de Ucfoutu
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, _
  ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 ' code libre d'utilisation et/ou diffusion. Seule obligation : y ajouter la mention suivante :
 ' ******code provenant du forum VBFrance de Codes-Sources - Auteur : ucfoutu*************
 
'____VARIABLES PRIVEES____
Private WithEvents monTextBoxAmoi As MSForms.TextBox
Private Obj
Private monUsfAmoi As Object
Private vrWin As Rect
Private lHwnd As Long, Haut As Long
Private cValue As String, Nom As String
Private Annuler As Boolean
 
'____CONSTANTE A modifier____
Private Const A_CORRIGER As Byte = 5  'A modifier
 
'____CONSTANTES____
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const SWP_FRAMECHANGED = &H20
 
'____PROPRIETE____
Public Property Get Value() As String
    Value = cValue
End Property
 
Private Property Let Value(V As String)
    cValue = V
End Property
 
'____EVENEMENTS____
Private Sub Class_Initialize()
'vérifie que l'accès au modèle objet du projet VBA a été approuvé
    Annuler = False
    On Error Resume Next
    With ThisWorkbook.VBProject: End With
    If Err <> 0 Then
        On Error GoTo 0
        MsgBox "Vous n'avez pas approuvé l'accès au modèle objet du projet VBA." _
                & vbCrLf & vbCrLf & "Pour cela, voir dans Options > Centre de gestion de la confidentialité > Paramètres des macros", vbCritical
        Annuler = True
    End If
End Sub
 
Private Sub monTextBoxAmoi_Change()
'chaque changement est enregistré
    Value = monTextBoxAmoi.Value
End Sub
 
Private Sub monTextBoxAmoi_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'La touche entrée masque l'userform avec modification de la valeur, la touche Echap masque et annule d'éventuelles modifications
    If KeyCode = 13 Or KeyCode = 27 Then monUsfAmoi.Hide
End Sub
 
Private Sub Class_Terminate()
'Supprime l'userform du projet VBA, s'il a été créé
Dim VBComp
    If Nom <> "" Then
        Set VBComp = ThisWorkbook.VBProject.VBComponents(Nom)
        ThisWorkbook.VBProject.VBComponents.Remove VBComp
        Set monTextBoxAmoi = Nothing
        Set monUsfAmoi = Nothing
    End If
End Sub
 
'____METHODES____
Public Sub Show(BckColor As Long, ForColor As Long, DefaultValeur As Variant, DefaultLargeur As Single, PositionX As Long, PositionY As Long, Police As StdFont)
    Call Add_TextBox(BckColor, ForColor, DefaultValeur, DefaultLargeur, Police)
    Call UserForm_Decore
    monUsfAmoi.Move PositionX, PositionY
    'affichage
    monUsfAmoi.Show
    monTextBoxAmoi.SetFocus
End Sub
 
Public Sub Add(DefaultValeur As String)
    'Annuler si l'accès au modèle objet du projet VBA n'a pas été approuvé
    If Annuler Then 'cf Private Sub Class_Initialize()
        cValue = DefaultValeur
        Exit Sub
    End If
    'appel des différentes méthodes
    Call UserForm_Add
End Sub
 
Private Sub UserForm_Add()
'Ajoute un UserForm dynamiquement au projet
    Set monUsfAmoi = ThisWorkbook.VBProject.VBComponents.Add(3)
    Nom = monUsfAmoi.Name
    VBA.UserForms.Add (Nom)
    Set monUsfAmoi = UserForms(UserForms.Count - 1)
    monUsfAmoi.StartUpPosition = 0
End Sub
 
Private Sub Add_TextBox(BckColor As Long, ForColor As Long, DefaultV As Variant, DefaultL As Single, P As StdFont)
'Ajoute un TextBox sur l'UserForm créé dynamiquement
    Set Obj = monUsfAmoi.Controls.Add("forms.TextBox.1")
    Set monTextBoxAmoi = Obj
    cValue = DefaultV
    Haut = hauteur(P)
    With monTextBoxAmoi
        .Move 0, 0, DefaultL, Haut
        .Value = cValue
        .BackColor = BckColor
        .ForeColor = ForColor
        .Font.Bold = P.Bold
        .Font.Italic = P.Italic
        .Font.Name = P.Name
        .Font.size = P.size
        .Font.Underline = P.Underline
        .Font.Strikethrough = P.Strikethrough
        .SetFocus
    End With
    Set Obj = Nothing
End Sub
 
Private Sub UserForm_Decore()
'"met en forme" l'UserForm créé dynamiquement
    monUsfAmoi.Width = monTextBoxAmoi.Width
    monUsfAmoi.Height = monTextBoxAmoi.Height
    Masque_Barre monUsfAmoi.Caption, False  'masque la barre de titre
    Coupe monUsfAmoi, monTextBoxAmoi        'découpe la partie éventuellement en trop
    monTextBoxAmoi.Width = monTextBoxAmoi.Width + A_CORRIGER
End Sub
 
Private Sub Masque_Barre(strCapt As String, pbVisible As Boolean)
'masque la barre de titre
Dim style As Long
'Unparia :
    'https://www.developpez.net/forums/d1736459-2/logiciels/microsoft-office/excel/contribuez/extraction-dimensions-plusieurs-elements-fenetre-application/#post9534999
    lHwnd = FindWindowA(vbNullString, strCapt)
    If lHwnd = 0 Then
        MsgBox "Handle de " & strCapt & " Introuvable", vbCritical
        Exit Sub
    End If
    GetWindowRect lHwnd, vrWin
    style = GetWindowLong(lHwnd, GWL_STYLE)
    If pbVisible Then
        SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
    Else
        SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
    End If
    SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
            vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub
 
Private Function Coupe(Usf As Object, TB As MSForms.TextBox)
'découpe la partie éventuellement en trop
Dim RgnA_Couper As Long, DeleT As Long, SetW As Long, Ppx As Double, Bord As Integer
 
    Ppx = dpi / 72
    Bord = IIf(IsAeroActivated, A_CORRIGER, 1)
    RgnA_Couper = CreateRectRgn(A_CORRIGER - Bord, A_CORRIGER - Bord, TB.Width * Ppx, (TB.Height * Ppx) + Bord)
    SetW = SetWindowRgn(lHwnd, RgnA_Couper, True)
    DeleT = DeleteObject(RgnA_Couper)
End Function
 
Private Function dpi() As Double
'Calcule le DPI (utilisé dans la Function Coupe)
'unparia
    'https://www.developpez.net/forums/d1696376/logiciels/microsoft-office/excel/contribuez/connaitre-dpi-resolution-ecran-api-window-gdi/#post9502928
Dim anc As Single
    With ActiveSheet.Range("A" & Rows.Count)
        anc = .RowHeight
        .RowHeight = 100.25
        If (.Height - Int(.Height)) * 100 Mod 25 = 0 And (.Height - Int(.Height)) > 0 Then
            dpi = 96
        ElseIf (.Height - Int(.Height)) * 1000 Mod 200 = 0 And (.Height - Int(.Height)) > 0 Then
            dpi = 120
        ElseIf (.Height - Int(.Height)) Mod 100 = 0 Then
            dpi = 144
        ElseIf (.Height - Int(.Height)) * 1000 Mod 125 = 0 Then
            dpi = 192
        End If
        .RowHeight = anc
    End With
End Function
 
Private Function IsAeroActivated() As Boolean
'vérifie si aero est activé ou pas (utilisé dans la Function Coupe)
Dim BOOLAero As BOOL
Const S_OK = 0&
 
    On Error Resume Next
    IsAeroActivated = (DwmIsCompositionEnabled(BOOLAero) = S_OK And BOOLAero = TRUE_)
    If Err <> 0 Then
        Err.Clear
        IsAeroActivated = False
    End If
End Function
 
Private Function hauteur(P As StdFont) As Single
    hauteur = dimt(cValue, P).Y
End Function
 
Private Function dimt(ch As String, ByVal pol As StdFont) As hv
 ' ******code provenant du forum VBFrance de Codes-Sources - Auteur : ucfoutu*************
Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline
    lgf.lfWeight = 400
    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteObject ccb: DeleteDC cdc
    dimt = tch
End Function
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
'La méthode Show comporte 7 paramètres :
            'BckColor As Long : Couleur de fond
            'ForColor As Long : Couleur de la police
            'DefaultValeur As Variant : Valeur par défaut (initiale)
            'DefaultLargeur As Single : Largeur
            'PositionX As Long : Coordonnée en abscisse par rapport à l'écran
            'PositionY As Long : Coordonnée en ordonnée par rapport à l'écran
            'Police As stdFont : La police à utiliser
Exemple de code appelant depuis un UserForm (au clic sur un Label1)
Donc un UserForm ou vous avez dessiné un label...
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
Option Explicit
 
Dim Instance As New clUsfTB
 
Private Sub Label1_Click()
Dim pol As StdFont
 
    Set pol = Me.Label1.Font
    Instance.Show 65000, 255, "TEST", 100, 250, 300, pol
    MsgBox Instance.Value
End Sub
 
Private Sub UserForm_Activate()
    Instance.Add "TEST"
End Sub