[source] une classe prête à l'emploi pour les ToolTipText (info bulles) [Sources]

**hpfx** · 03/09/2008, 15h03

Bonjour, je traine depuis quelques temps une classe qui permet d'afficher facilement des "Tool-Tip-Text" ("info bulles" en francais).
la base du code n'est pas de moi, celà vient de là : http://www.codeproject.com/KB/vb/balloon-tooltip.aspx
par contre je l'ai modifié pour la rendre vraiment plus facile.

A noter que celà fonctionne sous toutes plateforme windows (95 à vista) ce qui n'est pas mal. les info bulles ont un look type windows XP (pas trop moche donc) et est même multilinge (vbcrlf).

avant de mettre le code de la classe (fichier CToolTip) je vous met ici la manière dont on l'utilise :

Code :

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

1
2
3
4
5
6
7
8
9
10
    Dim TT as CtoolTip
    Set TT = New CTooltip
    TT.DelayTime = 100 '  1/10 sec pour afficher
    TT.VisibleTime = 5000 ' reste affiché 5 sec
'...
'quand on veux afficher... (dans un MouseMove par exemple)
Call TT.Display(obj.hwnd, "titre", "texte", TTIconInfo)
 
'quand on veux masquer (en sortie d'un controle par ex)
Call TT.Destroy

obj est le controle (un bouton par exemple) sur lequel est affiché le TT
d'une maniere generale, j'utilise un seul objet TT par form, vu qu'il n'est pas interessant d'en afficher 2 en même temps, comme j'en ai qu'un, j'ai pas ce probleme.
Note : on peut appeller un destroy sans risque même si la bulle n'a pas encore été appellé.

voilà, c'est simple à utiliser (a comparer de la version originale)
voici maintenant le code de la classe :

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
Option Explicit
 
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
 
''Windows API Functions
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 SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageLong Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DestroyWindow Lib "USER32" (ByVal hwnd As Long) As Long
 
''Windows API Constants
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
 
''Windows API Types
Private Type RECT
        Left As Long
        TOp As Long
        Right As Long
        Bottom As Long
End Type
 
''Tooltip Window Constants
Private Const TTS_NOPREFIX = &H2
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTS_ALWAYSTIP = &H1
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
 
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
 
''Tooltip Window Types
Private Type TOOLINFO
    lSize As Long
    lFlags As Long
    hwnd As Long
    lId As Long
    lpRect As RECT
    hInstance As Long
    lpStr As String
    lParam As Long
End Type
 
 
Public Enum ttIconType '<=== Ici les differentes icones possibles
    TTNoIcon = 0
    TTIconInfo = 1
    TTIconWarning = 2
    TTIconError = 3
End Enum
 
Public Enum ttStyleEnum
    TTStandard
    TTBalloon
End Enum
 
'local variable(s) to hold property value(s)
Private mvarBackColor As Long
Private mvarTitle As String
Private mvarForeColor As Long
Private mvarIcon As ttIconType
Private mvarCentered As Boolean
Private mvarStyle As ttStyleEnum
Private mvarTipText As String
Private mvarVisibleTime As Long
Private mvarDelayTime As Long
 
Private m_Show As Boolean
 
'Public mAffiche As Boolean ' affiché ou pas ?
'private data
Private m_lTTHwnd As Long ' hwnd of the tooltip
Private m_lParentHwnd As Long ' hwnd of the window the tooltip attached to
Private ti As TOOLINFO
 
Public Property Let Style(ByVal vData As ttStyleEnum)
   mvarStyle = vData
End Property
 
Public Property Get Style() As ttStyleEnum
   Style = mvarStyle
End Property
 
Public Property Let Centered(ByVal vData As Boolean)
   mvarCentered = vData
End Property
 
Public Property Get Centered() As Boolean
   Centered = mvarCentered
End Property
 
 
' la methode d'affichage nouvelle generation.
Public Sub Display(ByVal ParentHwnd As Long, ByRef titre As String, ByRef txt As String, i As ttIconType)
 If Not m_Show Then
      m_Show = True
      Title = titre
      Icon = i
      If Len(txt) > 115 Then ' nouv v3
        Dim p As Long
        p = InStr(110, txt, " ")
        If p >= 110 Then txt = Left(txt, p - 1) & vbCrLf & Mid(txt, p + 1)
      End If
      TipText = txt
      Create ParentHwnd
 End If
End Sub
 
Public Function Create(ByVal ParentHwnd As Long) As Boolean
   Dim lWinStyle As Long
 
'   If mAffiche Then Exit Function
'   mAffiche = True
 
   If m_lTTHwnd <> 0 Then
      DestroyWindow m_lTTHwnd
   End If
 
 
   m_lParentHwnd = ParentHwnd
 
   lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
 
   ''create baloon style if desired
   If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON
 
   m_lTTHwnd = CreateWindowEx(0&, _
      TOOLTIPS_CLASSA, _
      vbNullString, _
      lWinStyle, _
      CW_USEDEFAULT, _
      CW_USEDEFAULT, _
      CW_USEDEFAULT, _
      CW_USEDEFAULT, _
      0&, _
      0&, _
      App.hInstance, _
      0&)
 
   ''now set our tooltip info structure
   With ti
      ''if we want it centered, then set that flag
      If mvarCentered Then
         .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND
      Else
         .lFlags = TTF_SUBCLASS Or TTF_IDISHWND
      End If
 
      ''set the hwnd prop to our parent control's hwnd
      .hwnd = m_lParentHwnd
      .lId = m_lParentHwnd '0
      .hInstance = App.hInstance
      '.lpstr = ALREADY SET
      '.lpRect = lpRect
      .lSize = Len(ti)
   End With
 
   ''add the tooltip structure
   SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti
 
   ''if we want a title or we want an icon
   If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then
      SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
   End If
 
   If mvarForeColor <> Empty Then
      SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
   End If
 
   If mvarBackColor <> Empty Then
      SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
   End If
 
   SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, mvarVisibleTime
   SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, mvarDelayTime
End Function
 
Public Property Let Icon(ByVal vData As ttIconType)
   mvarIcon = vData
   If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
      SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
   End If
End Property
 
Public Property Get Icon() As ttIconType
   Icon = mvarIcon
End Property
 
Public Property Let ForeColor(ByVal vData As Long)
   mvarForeColor = vData
   If m_lTTHwnd <> 0 Then
      SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
   End If
End Property
 
Public Property Get ForeColor() As Long
   ForeColor = mvarForeColor
End Property
 
Public Property Let Title(ByVal vData As String)
   mvarTitle = vData
   If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
      SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
   End If
End Property
 
Public Property Get Title() As String
   Title = ti.lpStr
End Property
 
Public Property Let BackColor(ByVal vData As Long)
   mvarBackColor = vData
   If m_lTTHwnd <> 0 Then
      SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
   End If
End Property
 
Public Property Get BackColor() As Long
   BackColor = mvarBackColor
End Property
 
Public Property Let TipText(ByVal vData As String)
   mvarTipText = vData
   ti.lpStr = vData
   If m_lTTHwnd <> 0 Then
      SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti
   End If
End Property
 
Public Property Get TipText() As String
   TipText = mvarTipText
End Property
 
Private Sub Class_Initialize()
   InitCommonControls
   mvarDelayTime = 200
   mvarVisibleTime = 5000
   Style = TTBalloon ' val par defaut
   Icon = TTIconInfo ' val par defaut
   m_Show = False 'pas affiché par defaut'
End Sub
 
Private Sub Class_Terminate()
   Destroy
End Sub
 
Public Sub Destroy()
m_Show = False
   If m_lTTHwnd <> 0 Then
      DestroyWindow m_lTTHwnd
      m_lTTHwnd = 0
   End If
End Sub
 
Public Property Get VisibleTime() As Long
   VisibleTime = mvarVisibleTime
End Property
 
Public Property Let VisibleTime(ByVal lData As Long)
   mvarVisibleTime = lData
End Property
 
Public Property Get DelayTime() As Long
   DelayTime = mvarDelayTime
End Property
 
Public Property Let DelayTime(ByVal lData As Long)
   mvarDelayTime = lData
End Property
 
Public Property Get Show() As Boolean
Show = m_Show
End Property

Et surtout un merci à Nayan S. Patel, l'auteur original.
edit:ajout de remarques

**Vld44** · 06/10/2008, 14h32

salut hpfx,

ton truc m'intéresse peut-être, mais je me demande ce que ça apporte vraiment par rapport aux tooltips texts d'origine. Est-ce vraiment plus joli ?

Si t'avais un screenshot ... désolé j'en demande ptet un peu trop ..

A+, Seb

**hpfx** · 06/10/2008, 21h09

Envoyé par Vld44

salut hpfx,

ton truc m'intéresse peut-être, mais je me demande ce que ça apporte vraiment par rapport aux tooltips texts d'origine. Est-ce vraiment plus joli ?

Si t'avais un screenshot ... désolé j'en demande ptet un peu trop ..

A+, Seb

il faudrait que je fasse un screenshot , mais en attendant voilà déjà ce que ca apporte :
- possibilité de mettre un titre (optionel : apparait en gras)
- possibilité d'avoir une icone (optionel : une parmis 3)
- possibilité de faire des retours à la lignes (vbcrlf)
- rendu identique sur tout systeme (win95...) , avec les bords ronds (comme sous XP)
- on peut enfin parametrer les delais (fini les tooltip qui se ferment trop tôt)

**ProgElecT** · 25/11/2008, 20h40

Sympa cette classe, je me suis permis de l’utiliser pour aider dans cette discussion.

Salut

**littledoudou** · 12/02/2009, 14h18

tout d'abord, merci hpfx pour cette... petite perle.

ensuite, je me suis penché sur l'utilisation de ces info bulles en instanciant une seule classe (Nayan S. Patel en instanciait une différente pour chaque contrôle).

j'ai trouvé une solution en me basant sur le handle du contrôle en cours de traitement:
(sur un formulaire, j'ai créé un textbox et un commandbutton)

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
Option Explicit
 
Dim objToolTip As CToolTip
Dim lngHandle As Long
 
Private Sub Form_Load()
    Set objToolTip = New CToolTip
    objToolTip.DelayTime = 100
    objToolTip.VisibleTime = 2000
End Sub
 
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'nettoyage de l'objet ToolTip en cas de handle de contrôle différent
    If lngHandle <> Command1.hwnd Then
        Call objToolTip.Destroy
        lngHandle = Command1.hwnd
    End If
    'affichage du ToolTip sur le contrôle en cours
    Call objToolTip.Display(Command1.hwnd, "information", "Command1" & vbCrLf & "Command1", TTIconInfo)
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'nettoyage de l'objet ToolTip en cas de handle de contrôle différent
    If lngHandle <> Form1.hwnd Then
        Call objToolTip.Destroy
        lngHandle = Form1.hwnd
    End If
    'affichage du ToolTip sur le contrôle en cours
    Call objToolTip.Display(Form1.hwnd, "information", "Form1", TTIconWarning)
End Sub
 
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'nettoyage de l'objet ToolTip en cas de handle de contrôle différent
    If lngHandle <> Text1.hwnd Then
        Call objToolTip.Destroy
        lngHandle = Text1.hwnd
    End If
    'affichage du ToolTip sur le contrôle en cours
    Call objToolTip.Display(Text1.hwnd, "information", "Text1", TTIconError)
End Sub

s'il y a mieux, n'hésitez pas...

cdlt,

**hpfx** · 06/07/2010, 10h00

Envoyé par littledoudou

... je me suis penché sur l'utilisation de ces info bulles en instanciant une seule classe (Nayan S. Patel en instanciait une différente pour chaque contrôle).

Ben justement, c'est pour celà que j'ai modifié la classe : pour eviter d'instancier plusieurs fois.

Ton code :

Code :

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

1
2
3
4
5
6
7
8
 
    'nettoyage de l'objet ToolTip en cas de handle de contrôle différent
    If lngHandle <> Command1.hwnd Then
        Call objToolTip.Destroy
        lngHandle = Command1.hwnd
    End If
    'affichage du ToolTip sur le contrôle en cours
    Call objToolTip.Display(Command1.hwnd, "information", "Command1", TTIconWarning)

Envoyé par littledoudou

s'il y a mieux, n'hésitez pas...

Pas besoin de faire tout celà... (contrôle du handle)
C'est d'ailleurs pour celà que je fais passer le hwnd dans le Display.
Donc pas besoin de le "nettoyer" (c'est ce que fait ma classe)

Voilà, donc il ne reste que les Display() dans tes evenements MouseMove, on ne peut pas faire plus facile

En fait... c'est bien, tu as refais les modifs que j'avais fait... mais en dehors de la classe

**megamario** · 20/12/2017, 13h04

Bonjour,

Je vous remercie beaucoup hpfx , cela fait bien plus classe quand même.

J'ai toutefois rencontrés un petit souci.
J'ai plusieurs checkbox aux fonctions parfois exotique pour certains utilisateurs donc j'ai utilisé votre classe pour afficher de l'aide.

Et votre classe utilisée juste avec les MouseMove cela ne m'affichait que la 1ere infobulle que j'avais activé. Elle fonctionnait toutes mais seule la 1ere activée fonctionnait.

J'ai simplement détruit si besoin la classe avant de instancier de nouveau et cela fonctionne parfaitement. Certes que pendant la durée défini, mais cela suffit.
J'ai un enum (EtatToolTip ) que je positionne sur la bulle en cours pour éviter de reconstruire la bulle.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Private Sub ckUsine_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If EtatToolTip <> en_Usine Then
        EtatToolTip = en_Usine
        If Not TT Is Nothing Then
            Set TT = Nothing
        End If
        Set TT = New CtoolTip
        TT.DelayTime = TTDelayTime '100 '  1/10 sec pour afficher
        TT.VisibleTime = TTDelayStop ' 5000 ' reste affiché 5 sec
 
        Call TT.Display(ckUsine.hwnd, ckUsine.Caption, msgToolTip_ckUsine, TTIconInfo)
    End If
End Sub

Je fait pareil à chaque fois que je souhaite l'utiliser et cela fonctionne très bien.

En tout cas, encore une fois, je vous remercie.

[EDIT]
Je me suis permis de modifier un peu la partie Display, afin de couper automatiquement le texte, mais en tenant compte s'il y a des CRLF déjà présent. Il y a peut être plus simple.

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
Public Sub Display(ByVal ParentHwnd As Long, ByRef titre As String, ByRef txt As String, i As ttIconType)
 If Not m_Show Then
      m_Show = True
      Title = titre
      Icon = i
      If Len(txt) > 115 Then ' nouv v3
        Dim cut() As String
        Dim y As Integer
        Dim str As String
        Dim modif As Boolean
retest:
        modif = False
        str = ""
        cut = Split(txt, vbCrLf)
        For y = 0 To UBound(cut)
            If Len(cut(y)) > 115 Then
                modif = True
                Dim p As Long
                p = InStr(110, cut(y), " ")
                If p >= 110 Then cut(y) = Left(cut(y), p - 1) & vbCrLf & Mid(cut(y), p + 1)
            End If
            If str = "" Then
                str = cut(y)
            Else
                str = str & vbCrLf & cut(y)
            End If
        Next
        txt = str
        If modif Then
            GoTo retest
        End If
      End If
      TipText = txt
      Create ParentHwnd
 End If
End Sub

[source] une classe prête à l'emploi pour les ToolTipText (info bulles) [Sources]

Vos contributions VB6

Discussions similaires

Partager

Partager