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
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
| '***************************************************************************************
'* CLASSE POUR TOOLTIP *
'***************************************************************************************
'***************************************************************************************
' Auteur : Thierry GASPERMENT (Arkham46)
' v0.1 20/03/08
' Le code est libre pour toute utilisation
'***************************************************************************************
' Fonctionne uniquement pour des contrôles "dessinés"
' Ne fonctionne pas : listbox, activex, ...
'***************************************************************************************
' Contrôle ToolTip sur MSDN
' http://msdn2.microsoft.com/en-us/library/bb760246(VS.85).aspx
'***************************************************************************************
'***************************************************************************************
' EN-TÊTE
'***************************************************************************************
#Const Access = True ' Mettre à True pour Access, à False pour Excel
#If Access Then
Option Compare Database
#End If
Option Explicit
'***************************************************************************************
' TYPES
'***************************************************************************************
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As Long
#If VBA7 Then
hWnd As LongPtr
#Else
hWnd As Long
#End If
uId As Long
RECT As RECT
hinst As Long
lpszText As String
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
'***************************************************************************************
' API
'***************************************************************************************
#If VBA7 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function InitCommonControls Lib "comctl32.dll" () As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As Long
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, _
ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, _
ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, _
ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, _
ByVal lpszFace As String) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
#Else
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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, _
ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, _
ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, _
ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, _
ByVal lpszFace As String) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If
'***************************************************************************************
' CONSTANTES
'***************************************************************************************
' Nom de la classe du common control ToolTip
Private Const TOOLTIPS_CLASS As String = "tooltips_class32"
' Message pour contrôle ToolTip
Private Const WM_USER As Long = &H400
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_GETTOOLCOUNT = WM_USER + 13
Private Const TTM_ADDTOOL = WM_USER + 4
Private Const TTM_DELTOOL = WM_USER + 5
Private Const TTM_GETTOOLINFO = WM_USER + 8
Private Const TTM_UPDATETIPTEXT = WM_USER + 12
Private Const TTM_ENUMTOOLS = WM_USER + 14
Private Const TTM_TRACKACTIVATE = WM_USER + 17
Private Const TTM_TRACKPOSITION = WM_USER + 18
Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
Private Const TTM_GETDELAYTIME = WM_USER + 21
Private Const TTM_GETTIPBKCOLOR = WM_USER + 22
Private Const TTM_GETTIPTEXTCOLOR = WM_USER + 23
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_GETMAXTIPWIDTH = WM_USER + 25
Private Const TTM_GETBUBBLESIZE = WM_USER + 30
Private Const TTM_ADJUSTRECT = WM_USER + 31
Private Const TTM_SETTITLE = WM_USER + 32
' Style de fenêtre
Private Const WS_POPUP As Long = &H80000000
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_BALLOON As Long = &H40
' Délais d'affichage
Private Const TTDT_RESHOW As Long = 1
Private Const TTDT_AUTOPOP As Long = 2
Private Const TTDT_INITIAL As Long = 3
' Flags pour Tool
Private Const TTF_CENTERTIP As Long = &H2
Private Const TTF_SUBCLASS As Long = &H10
Private Const TTF_TRANSPARENT As Long = &H100
' Autres constantes
Private Const GWL_HINSTANCE As Long = &HFFFA ' Pour lire l'instance
Private Const GWL_STYLE As Long = &HFFF0 ' Style de fenêtre
Private Const GWL_EXSTYLE As Long = &HFFEC ' Style de fenêtre étendu
Private Const WS_EX_LAYERED As Long = &H80000 ' Style de fenêtre pour transparence
Private Const LWA_ALPHA As Long = &H2 ' Constante pour définition de la transparence
Private Const CW_USEDEFAULT As Long = &H80000000 ' Constante pour taille par défaut
Private Const LOGPIXELSX As Long = 88 ' Constantes pour nombre de pixels par pouces
Private Const LOGPIXELSY As Long = 90 ' Constantes pour nombre de pixels par pouces
Private Const WM_SETFONT As Long = &H30 ' Message pour modification de police de caractères
'***************************************************************************************
' VARIABLES
'***************************************************************************************
#If VBA7 Then
Private gHwnd As LongPtr ' Handle du control ToolTip
Private gFormHwnd As LongPtr ' Handle du formulaire parent
#Else
Private gHwnd As Long ' Handle du control ToolTip
Private gFormHwnd As Long ' Handle du formulaire parent
#End If
Private gTitle As String ' Titre du control
Private gIcon As Long ' Icon du control
Private gEnabled As Boolean ' Activé ou désactivé
Private gInstance As Long ' Instance de l'application en cours
Private gTransparent As Long ' Transparence du ToolTip (0 = transparent; 100 = opaque)
Private gControls As Collection ' Collection contenant les Id des contrôles insérés
Private gFont As Long ' Police de caractères
'***************************************************************************************
' ENUMERATIONS
'***************************************************************************************
' Type d'icone dans le titre
#If VBA6 Then
Public Enum EToolTipIcon
TTI_NONE = 0
TTI_INFO = 1
TTI_WARNING = 2
TTI_ERROR = 3
End Enum
#End If
'***************************************************************************************
' PROPRIETES
'***************************************************************************************
' Active ou désactive le tooltip
Public Property Get Enabled() As Boolean
Enabled = gEnabled
End Property
Public Property Let Enabled(pEnabled As Boolean)
' (TTM_ACTIVATE ne renvoit pas de valeur)
Call SendMessage(gHwnd, TTM_ACTIVATE, pEnabled, ByVal 0)
gEnabled = pEnabled
End Property
' Affichage du ToolTip même si fenêtre inactive
Public Property Get AlwaysTip() As Boolean
Dim lStyle As Long
lStyle = GetWindowLong(gHwnd, GWL_STYLE)
AlwaysTip = (lStyle And TTS_ALWAYSTIP)
End Property
Public Property Let AlwaysTip(pAlwaysTip As Boolean)
Dim lStyle As Long
lStyle = GetWindowLong(gHwnd, GWL_STYLE)
If pAlwaysTip Then
lStyle = lStyle Or TTS_ALWAYSTIP
Else
lStyle = lStyle Xor TTS_ALWAYSTIP
End If
SetWindowLong gHwnd, GWL_STYLE, lStyle
End Property
' Affichage du ToolTip en forme de ballon
Public Property Get Balloon() As Boolean
Dim lStyle As Long
lStyle = GetWindowLong(gHwnd, GWL_STYLE)
Balloon = (lStyle And TTS_BALLOON)
End Property
Public Property Let Balloon(pBalloon As Boolean)
Dim lStyle As Long
lStyle = GetWindowLong(gHwnd, GWL_STYLE)
If pBalloon Then
lStyle = lStyle Or TTS_BALLOON
Else
lStyle = lStyle Xor TTS_BALLOON
End If
SetWindowLong gHwnd, GWL_STYLE, lStyle
End Property
' Délais avant affichage en millisecondes
Public Property Get DelayInitial() As Long
DelayInitial = SendMessage(gHwnd, TTM_GETDELAYTIME, TTDT_INITIAL, ByVal 0)
End Property
Public Property Let DelayInitial(pDelay As Long)
Call SendMessage(gHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal pDelay)
End Property
' Durée d'affichage en millisecondes
Public Property Get DelayPopup() As Long
DelayPopup = SendMessage(gHwnd, TTM_GETDELAYTIME, TTDT_AUTOPOP, ByVal 0)
End Property
Public Property Let DelayPopup(pDelay As Long)
Call SendMessage(gHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, ByVal pDelay)
End Property
' Délais avant réaffichage lors du passage d'un contrôle à un autre
Public Property Get DelayReShow() As Long
DelayReShow = SendMessage(gHwnd, TTM_GETDELAYTIME, TTDT_RESHOW, ByVal 0)
End Property
Public Property Let DelayReShow(pDelay As Long)
Call SendMessage(gHwnd, TTM_SETDELAYTIME, TTDT_RESHOW, ByVal pDelay)
End Property
' Couleur de fond
Public Property Get BackColor() As Long
BackColor = SendMessage(gHwnd, TTM_GETTIPBKCOLOR, 0, ByVal 0)
End Property
Public Property Let BackColor(pColor As Long)
' (TTM_SETTIPBKCOLOR ne renvoit pas de valeur)
Call SendMessage(gHwnd, TTM_SETTIPBKCOLOR, pColor, ByVal 0)
End Property
' Couleur du texte
Public Property Get TextColor() As Long
TextColor = SendMessage(gHwnd, TTM_GETTIPTEXTCOLOR, 0, ByVal 0)
End Property
Public Property Let TextColor(pColor As Long)
' (TTM_SETTIPTEXTCOLOR ne renvoit pas de valeur)
Call SendMessage(gHwnd, TTM_SETTIPTEXTCOLOR, pColor, ByVal 0)
End Property
' Largeur maximale du tooltip en pixels
' MaxTipWidth doit être différent de -1 pour afficher des textes multi-lignes (avec vbcrlf)
Public Property Get MaxTipWidth() As Long
MaxTipWidth = SendMessage(gHwnd, TTM_GETMAXTIPWIDTH, ByVal 0, ByVal 0)
End Property
Public Property Let MaxTipWidth(ByVal pMaxTipWidth As Long)
Call SendMessage(gHwnd, TTM_SETMAXTIPWIDTH, ByVal 0, ByVal pMaxTipWidth)
End Property
' Texte du tooltip pour un contrôle (écriture seule)
Public Property Let ControlText(pControl As Control, Optional pSubId As Integer, pText As String)
Dim lTi As TOOLINFO
#If VBA7 Then
lTi.cbSize = LenB(lTi)
#Else
lTi.cbSize = Len(lTi)
#End If
lTi.hWnd = gFormHwnd
lTi.hinst = gInstance
lTi.uId = GetControlId(pControl, pSubId)
lTi.lpszText = pText
Call SendMessage(gHwnd, TTM_UPDATETIPTEXT, ByVal 0, lTi)
End Property
' Titre du tooltip (pour tous les contrôles)
Public Property Let Title(ByVal pText As String)
If SendMessage(gHwnd, TTM_SETTITLE, gIcon, ByVal pText) Then
gTitle = pText
End If
End Property
Public Property Get Title() As String
Title = gTitle
End Property
' Icone du tooltip
' Aucune = 0
' Info = 1
' Warning = 2
' Error = 3
#If VBA6 Then
Public Property Let Icon(ByVal pIcon As EToolTipIcon)
#Else
Public Property Let Icon(ByVal pIcon As Long)
#End If
' Si pas de titre, force l'affichage de l'icone avec un titre = espace
If gTitle = "" Then gTitle = " "
If SendMessage(gHwnd, TTM_SETTITLE, pIcon, ByVal gTitle) Then
gIcon = pIcon
End If
End Property
Public Property Get Icon() As Long
Icon = gIcon
End Property
'---------------------------------------------------------------------------------------
' Transparence du tooltip (0 à 100)
'---------------------------------------------------------------------------------------
Public Property Get Transparent() As Long
Transparent = gTransparent
End Property
Public Property Let Transparent(pAlpha As Long)
Dim lAlpha As Long
On Error GoTo Gestion_Erreurs
lAlpha = 255 * (pAlpha / 100)
If pAlpha = 0 Then
SetWindowLong gHwnd, GWL_EXSTYLE, GetWindowLong(gHwnd, GWL_EXSTYLE) Xor WS_EX_LAYERED
Else
SetWindowLong gHwnd, GWL_EXSTYLE, GetWindowLong(gHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes gHwnd, 0, lAlpha, LWA_ALPHA
End If
gTransparent = pAlpha
On Error GoTo 0
Exit Property
Gestion_Erreurs:
MsgBox "Error " & Err.NUMBER & " (" & Err.Description & ") dans la propriété Transparent du module ClTImer"
End Property
' Nombre de contrôles dans le tooltip
Public Property Get Count() As Long
Count = SendMessage(gHwnd, TTM_GETTOOLCOUNT, ByVal 0, ByVal 0)
End Property
'***************************************************************************************
' FONCTIONS / PROCEDURES
'***************************************************************************************
'---------------------------------------------------------------------------------------
' Définition du formulaire parent et création du control ToolTip
'---------------------------------------------------------------------------------------
Public Function SetForm(pForm As Object) As Boolean
On Error GoTo Gestion_Erreurs
' Ne poursuit pas la fonction si le contrôle est déjà créé
If gHwnd <> 0 Then
SetForm = False
Exit Function
End If
' Handle du formulaire parent
#If Access Then
gFormHwnd = pForm.hWnd
#Else
gFormHwnd = GetUserFormHandle(pForm, True)
#End If
' Initialise les Common Controls
Call InitCommonControls
' Lecture de l'instance à laquelle appartient le formulaire
gInstance = GetWindowLong(gFormHwnd, GWL_HINSTANCE)
' Création de la fenêtre de classe tooltips_class32
' TTS_ALWAYSTIP pour affichage même si fenêtre inactive
' TTS_BALLOON pour style bulle
' Parent de la fenêtre = le formulaire
gHwnd = CreateWindowEx(0&, TOOLTIPS_CLASS, vbNullString, WS_POPUP Or TTS_ALWAYSTIP Or TTS_BALLOON, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, gFormHwnd, _
0&, gInstance, 0&)
' ToolTip Activé par défaut
gEnabled = True
' Transparence à 100 par défaut (=opaque)
gTransparent = 100
' Largeur maxi = 400 pixels par défaut
Call SendMessage(gHwnd, TTM_SETMAXTIPWIDTH, ByVal 0, ByVal 400)
' Délais initial
DelayInitial = 500
' Renvoit vrai si le contrôle ToolTip a été crée
SetForm = (gHwnd <> 0)
On Error GoTo 0
Exit Function
Gestion_Erreurs:
If gHwnd <> 0 Then DestroyWindow gHwnd
SetForm = False
End Function
'---------------------------------------------------------------------------------------
' Ajout d'un contrôle au tooltip
'---------------------------------------------------------------------------------------
Public Function AddControl(pControl As Control, Optional pText As String, Optional pCenter As Boolean = False, Optional pSubId As Integer, Optional pX1 As Long = -1, Optional pY1 As Long = -1, Optional pX2 As Long = -1, Optional pY2 As Long = -1) As Boolean
Dim lTi As TOOLINFO
Dim lHeader As Long, lFooter As Long
On Error GoTo Gestion_Erreurs
' Création du common control si pas déjà créé
If gHwnd = 0 Then
If Not SetForm(pControl.Parent) Then
AddControl = False
Exit Function
End If
End If
' Recherche du contrôle pControl dans le ToolTip
#If VBA7 Then
lTi.cbSize = LenB(lTi)
#Else
lTi.cbSize = Len(lTi)
#End If
lTi.hWnd = gFormHwnd
lTi.uId = GetControlId(pControl, pSubId)
' Si le contrôle est déjà ajouté au ToolTip, on le supprime avant de le recréer
If SendMessage(gHwnd, TTM_GETTOOLINFO, ByVal 0, lTi) Then
Call SendMessage(gHwnd, TTM_DELTOOL, 0, lTi)
End If
' Création d'un ToolTip pour un rectangule
With lTi
#If VBA7 Then
.cbSize = LenB(lTi)
#Else
.cbSize = Len(lTi)
#End If
' TTF_SUBCLASS pour un contrôle "dessiné" sur le formulaire (pas de Hwnd)
' TTF_TRANSPARENT pour click "au travers" du tooltip
' TTF_CENTERTIP pour tooltip centré
.uFlags = TTF_SUBCLASS Or TTF_TRANSPARENT Or -pCenter * TTF_CENTERTIP
' Handle du formulaire
.hWnd = gFormHwnd
' Instance de l'application
.hinst = gInstance
' Texte du tooltip
.lpszText = pText
' Rectangle contenant le contrôle
' Ajoute les coordonnées éventuellement passées en paramètres
If pX1 <> -1 Then
.RECT.left = PointsToPixelsX(pControl.left + pX1)
Else
.RECT.left = PointsToPixelsX(pControl.left)
End If
If pX2 <> -1 Then
.RECT.right = PointsToPixelsX(pControl.left + pX2)
Else
.RECT.right = PointsToPixelsX(pControl.left + pControl.Width)
End If
If pY1 <> -1 Then
.RECT.top = PointsToPixelsY(pControl.top + pY1)
Else
.RECT.top = PointsToPixelsY(pControl.top)
End If
If pY2 <> -1 Then
.RECT.bottom = PointsToPixelsY(pControl.top + pY2)
Else
.RECT.bottom = PointsToPixelsY(pControl.top + pControl.Height)
End If
' Lecture de l'Id
.uId = GetControlId(pControl, pSubId)
' Pour Access, ajoute l'en-tête, le pied de formulaire, la taille du sélecteur
#If Access Then
' Ajout taille sélecteur
.RECT.left = .RECT.left + PointsToPixelsX(pControl.Parent.CurrentSectionLeft)
.RECT.right = .RECT.right + PointsToPixelsX(pControl.Parent.CurrentSectionLeft)
On Error Resume Next
' Recherche de la taille d'une éventuelle section "En-tête de formulaire"
If pControl.Parent.Section(acHeader).Visible = True Then lHeader = pControl.Parent.Section(acHeader).Height
' Recherche de la taille d'une éventuelle section "Pied de formulaire"
If pControl.Parent.Section(acFooter).Visible = True Then lFooter = pControl.Parent.Section(acFooter).Height
On Error GoTo Gestion_Erreurs
' Ajout taille en-tête de formulaire
If pControl.Section <> acHeader Then
.RECT.top = .RECT.top + PointsToPixelsY(lHeader)
.RECT.bottom = .RECT.bottom + PointsToPixelsY(lHeader)
End If
' Ajout taille de la section détail
If pControl.Section = acFooter Then
.RECT.top = .RECT.top + PointsToPixelsY(pControl.Parent.InsideHeight - lHeader - lFooter)
.RECT.bottom = .RECT.bottom + PointsToPixelsY(pControl.Parent.InsideHeight - lHeader - lFooter)
End If
#End If
End With
' Ajoute le contrôle et renvoit Vrai si OK
AddControl = SendMessage(gHwnd, TTM_ADDTOOL, 0, lTi)
On Error GoTo 0
Exit Function
Gestion_Erreurs:
AddControl = False
End Function
'---------------------------------------------------------------------------------------
' Retrait d'un contrôle du tooltip
'---------------------------------------------------------------------------------------
Public Sub RemoveControl(pControl As Control, Optional pSubId As Integer)
Dim lTi As TOOLINFO
On Error GoTo Gestion_Erreurs
' Supprime le contrôle du tooltip
#If VBA7 Then
lTi.cbSize = LenB(lTi)
#Else
lTi.cbSize = Len(lTi)
#End If
lTi.uId = GetControlId(pControl, pSubId)
Call SendMessage(gHwnd, TTM_DELTOOL, 0, lTi)
On Error GoTo 0
Exit Sub
Gestion_Erreurs:
MsgBox "Error " & Err.NUMBER & " (" & Err.Description & ") dans la procédure RemoveControl du module ClTImer"
End Sub
'---------------------------------------------------------------------------------------
' Retrait de tous les contrôles d'un tooltip
'---------------------------------------------------------------------------------------
Public Sub RemoveAllControls()
Dim lcpt As Long
Dim lTi As TOOLINFO
Dim lCount As Long
On Error GoTo Gestion_Erreurs
' Taille de la structure
#If VBA7 Then
lTi.cbSize = LenB(lTi)
#Else
lTi.cbSize = Len(lTi)
#End If
' Boucle sur les contrôles du tooltip
lCount = SendMessage(gHwnd, TTM_GETTOOLCOUNT, ByVal 0, ByVal 0)
For lcpt = 0 To lCount - 1
' Lecture des données (notamment l'Id) du contrôle d'indice 0
If SendMessage(gHwnd, TTM_ENUMTOOLS, 0, lTi) Then
' Supprime le contrôle du tooltip
Call SendMessage(gHwnd, TTM_DELTOOL, 0, lTi)
End If
Next
On Error GoTo 0
Exit Sub
Gestion_Erreurs:
MsgBox "Error " & Err.NUMBER & " (" & Err.Description & ") dans la procédure RemoveAllControls du module ClTImer"
End Sub
'---------------------------------------------------------------------------------------
' Force l'affichage d'un tooltip
' Ne peut être activé que pour un contrôle à la fois
' Si centré => Affichage sous le contôle, sinon affichage à l'emplacement du curseur
' Attention : ne suit pas automatiquement le formulaire lors de son déplacement
'---------------------------------------------------------------------------------------
Public Function ShowControl(pControl As Control, Optional pActive As Boolean = True, Optional pSubId As Integer) As Boolean
Dim lTi As TOOLINFO
Dim lpt As POINTAPI
On Error GoTo Gestion_Erreurs
' Tooltip créé?
If (gHwnd = 0) Then Exit Function
' Recherche les infos pour le contrôle ctl
#If VBA7 Then
lTi.cbSize = LenB(lTi)
#Else
lTi.cbSize = Len(lTi)
#End If
lTi.hWnd = gFormHwnd
lTi.uId = GetControlId(pControl, pSubId)
' Active ou désactive le suivi
Call SendMessage(gHwnd, TTM_TRACKACTIVATE, pActive, lTi)
' Positionne à la position du curseur à l'écran
If pActive Then
GetCursorPos lpt
Call SendMessage(gHwnd, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(lpt.X), CInt(lpt.Y)))
End If
ShowControl = True
On Error GoTo 0
Exit Function
Gestion_Erreurs:
ShowControl = False
End Function
'---------------------------------------------------------------------------------------
' Changement police de caractères
'---------------------------------------------------------------------------------------
Public Sub SetFont(Optional pFontName As String = "Arial", Optional pFontSize As Long = 8, _
Optional pBold As Boolean)
' Supprime l'ancienne police de caractères
If gFont <> 0 Then DeleteObject gFont
' Crée une nouvelle police
gFont = CreateFont(-((pFontSize / 72) * 96), 0, 0, 0, -pBold * 700, 0, 0, 0, 0, 0, 0, 0, 0, pFontName)
If gFont = 0 Then
' Police par défaut si échec de création de police
SendMessage gHwnd, WM_SETFONT, ByVal 0&, True
Else
' Affecte la police au contrôle
Call SendMessage(gHwnd, WM_SETFONT, gFont, True)
End If
End Sub
'---------------------------------------------------------------------------------------
' Police de caractères par défaut
'---------------------------------------------------------------------------------------
Public Sub ResetFont()
' Réinitialise la police de caractères par défaut
SendMessage gHwnd, WM_SETFONT, ByVal 0&, True
' Supprime l'ancienne police de caractères
If gFont <> 0 Then DeleteObject gFont
End Sub
'---------------------------------------------------------------------------------------
' Initialisation de la classe
'---------------------------------------------------------------------------------------
Private Sub class_initialize()
' Nouvelle collection pour Id des contrôles
Set gControls = New Collection
End Sub
'---------------------------------------------------------------------------------------
' Fermeture de la classe
'---------------------------------------------------------------------------------------
Private Sub class_terminate()
' Détruit le tooltip
If gHwnd <> 0 Then
Call DestroyWindow(gHwnd)
End If
' Détruit la collection d'ID
Set gControls = Nothing
' Détruit la police de caractères
If gFont <> 0 Then DeleteObject gFont
End Sub
#If Access = False Then
'---------------------------------------------------------------------------------------
' Handle d'un UserForm Excel
'---------------------------------------------------------------------------------------
' pForm : Formulaire
'---------------------------------------------------------------------------------------
Private Function GetUserFormHandle(pForm As Object, Optional pClientArea As Boolean = False) As Long
On Error GoTo Gestion_Erreurs
If val(Application.Version) < 9 Then
' Excel 97 or earlier
GetUserFormHandle = FindWindow("ThunderXFrame", pForm.Caption)
Else
' Excel 2000 or later
GetUserFormHandle = FindWindow("ThunderDFrame", pForm.Caption)
End If
' Zone client du formulaire
If pClientArea Then GetUserFormHandle = FindWindowEx(GetUserFormHandle, 0, "F3 Server 60000000", vbNullString)
On Error GoTo 0
Exit Function
Gestion_Erreurs:
MsgBox "Error " & Err.NUMBER & " (" & Err.Description & ") dans la procédure GetUserFormHandle du module ClTImer"
End Function
#End If
'---------------------------------------------------------------------------------------
' Id d'un contrôle
'---------------------------------------------------------------------------------------
Private Function GetControlId(pControl As Control, pSubId As Integer) As Long
Dim lKey As String
Dim lId As Long
Static sId As Long ' Compteur static
On Error GoTo Gestion_Erreurs
' Clé = Nom du contrôle + Espace + Sous-Identifiant
lKey = CStr(pControl.Name & " " & pSubId)
' Lecture de l'Id correspondant dans la collection
On Error Resume Next
lId = gControls.item(lKey)
On Error GoTo Gestion_Erreurs
If lId <> 0 Then
' Id trouvé, on le renvoit
GetControlId = lId
Else
' Id non trouvé, on ajoute une entrée dans la collection
sId = sId + 1
gControls.Add sId, lKey
End If
Exit Function
Gestion_Erreurs:
MsgBox "Error " & Err.NUMBER & " (" & Err.Description & ") dans la Function GetControlId du module ClToolTip"
End Function
'---------------------------------------------------------------------------------------
' Converti les points en Pixels sur l'axe horizontal
'---------------------------------------------------------------------------------------
' pPointsX : Valeur à convertir en points
' Renvoie la valeur convertie en Pixels
'---------------------------------------------------------------------------------------
Public Function PointsToPixelsX(pPointsX As Long) As Long
Static Mult As Single
Dim hDc As Long
If Mult = 0 Then
hDc = GetDC(0)
#If Access Then
Mult = 1440 / GetDeviceCaps(hDc, LOGPIXELSX)
#Else
Mult = 72 / GetDeviceCaps(hDc, LOGPIXELSX)
#End If
ReleaseDC 0, hDc
End If
PointsToPixelsX = CLng(pPointsX / Mult)
End Function
'---------------------------------------------------------------------------------------
' Converti les Points en Pixels sur l'axe vertical
'---------------------------------------------------------------------------------------
' pPointsY : Valeur à convertir en Points
' Renvoie la valeur convertie en Pixels
'---------------------------------------------------------------------------------------
Public Function PointsToPixelsY(pPointsY As Long) As Long
Static Mult As Single
Dim hDc As Long
If Mult = 0 Then
hDc = GetDC(0)
#If Access Then
Mult = 1440 / GetDeviceCaps(hDc, LOGPIXELSY)
#Else
Mult = 72 / GetDeviceCaps(hDc, LOGPIXELSY)
#End If
ReleaseDC 0, hDc
End If
PointsToPixelsY = CLng(pPointsY / Mult)
End Function
'---------------------------------------------------------------------------------------
' Fonctions pour DWord (source http://support.microsoft.com/kb/189170/fr)
'---------------------------------------------------------------------------------------
Private Function LoWord(DWord As Long) As Integer
If DWord And &H8000& Then ' &H8000& = &H00008000
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function
Private Function HiWord(ByVal DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
Private Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function |
Info Bulle sur un contrôle sous win 7 64Bit Module ClToolTip (Arkham46)
Répondre avec citation
Partager