[Toutes versions] Infobulle pour valeurs dans une Liste déroulante

[damsmut]

Bonjour à tous,

J'ai une liste déroulante avec des données trop longues que je n'arrive donc pas à afficher complètement dans la liste déroulante.

Est-il possible de faire apparaître par exemple une infobulle au survol de la souris sur une valeur de la liste déroulante ?

Ou une autre idée ?

Merci

a+
Dams'

[paidge]

Bonjour,

Tu peux modifier la largeur de ta liste déroulante quand elle est déployée.
Pour cela il faut modifier la propriété ListWidth (Largeur Liste) de ton contrôle.

NB : tu peux aussi modifier la largeur de chaque colonne. (à 0 la colonne est masquée)

[damsmut]

ok ListWidth je ne connaissais pas... je prends ! Merci.

mais si quelqu'un à une solution de type infobulle je préfèrerai...

[paidge]

Pour l'infobulle, il doit y avoir un article dans les tutos ou la FAQ

[damsmut]

j'avais cherché sans succès , c'est pour cela que j'ai posté

[paidge]

Ah bah je sais plus où je l'ai vu ce tuto...c'est bête parce que je vais bientôt en avoir besoin...Sinon je viens de trouver ça qui peut peut-être t'être utile

[damsmut]

ton lien me donne une page vide... et si tu retrouvs ton tuto... je serai toujours preneur

[paidge]

euh si tu as une page vide, c'est peut-être le proxy de là où tu bosses qui le bloque...Chez moi le lien fonctionne très bien. Sinon je penserais à toi si je retrouve le tuto (il était un peu complexe car il s'agissait de concevoir soi-même des info-bulles à partir de formulaires)

[ilank]

Bonjour,
il faut passer par l'interface IAccessible de la listbox. Utiliser la fonction cachée AccHitTest qui pour une position de curseur donné renvoie l'index+1 de l'élément survolé.

Exemple de code à placer dans le formulaire. Pour l'exemple j'appelle la liste Liste.

Code :

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
 
'Structure POINT renseigner par l'API user32.dll/GetCursorPos
Private Type POINT
 x as long
 y as long
End Type
 
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint as POINT) as long
 
'Conserve l'ancien index survolé
Dim oldIndex as Integer
Const TT_COLUMN = 0 'Mettre ici l'index de la colonne servant pour le tooltip
 
Private Sub Liste_MouseMove(Button as Integer, Shift as Integer, X as Single, Y as Single)
 Dim ptrPOINT as POINT
 Dim apiERROR as long
 Dim currIndex as integer
'Recuperer la position du curseur 
 apiERROR=GetCursorPos(ptrPOINT)
'Recuperer l'indice de l'élément survolé 
 currIndex=Liste.AccHitTest(ptrPOINT.x, ptrPOINT.y) - 1
 
'Si l'item survolé est le même que précédemment sortir
'Sinon un effet de scintillement apparaît 
 If currIndex = oldIndex then Exit Sub
'Reaffecter le ToolTip avec la valeur de colonne TT_COLUMN de l'item survolé 
 Liste.ControlTipText=Liste.Column(TT_COLUMN, currIndex)
 oldIndex=currIndex 
End Sub

[damsmut]

Salut Ilank,

l'interface IAccessible

Où trouve t on cette interface ? C'est quoi... ça sort d'où ? Y'a t il un menu pour ça ? ... ou bien c'est juste via du code VBA ?


Bon en tout cas, j'ai essayé... Je n'y arrive pas...

J'ai créé un formulaire vierge, y ai ajouté une liste déroulante nommé "Liste"... et ensuite ai copié ton code vba sur le formulaire tel quel...

et ça plante direct sur déplacement de la souris... il dit que : "l'expression sur souris déplacée entrée comme paramètre de la propriété de type événement est à l'origine d'une erreur. La déclaration de la procédure ne correspond pas à la description de l'événement ou de la procédure de même nom."

[damsmut]

Code :

Private Sub Liste_MouseMove(Byval .....

ah je viens d'essayer en supprimant Byval... et je n'ai plus ce message d'erreur...

par contre cela ne marche toujours pas...

Je clic sur la flèche de la liste pour la dérouler... et lorsque je bouge la souris, la liste disparaît... et ainsi de suite...

[ilank]

Bonjour,

l'interface IAccessible ne doit être disponible que depuis la version 2000 ou 2002( XP) d'Office, je crois.
Dans l'explorateur d'objets sous VBA, cocher Afficher les objets masqués.
Les controles Access (TextBox, ListBox....) devraient disposer de méthodes et propriétés commençant par Acc (AccChild, AccChildCount,AccHitTest,....).

Oh !! Je n'ai pas lu ceci

J'ai une liste déroulante

Le code marche pour une liste et non une liste déroulante. Je vais voir ce qu'il faut corriger.

[ilank]

Bonjour,
pour une liste déroulante c'est un poil plus compliqué.
D'abord le tooltip est associé avec la zone de saisie et non la liste. La fenêtre présentant la liste est recrée à la volée. Il faut donc créer une fenêtre ToolTip via un CreateWindowEx, lui associée la fenêtre de la liste, lui affecter le rectangle de cette fenêtre, et et modifier son libellé par celui de l'item survolé.

Voici un exemple :

[damsmut]

je t'avouerais que je suis un peu largué là

est-ce que tu pourrais mettre en téléchargement l'exemple que tu as fait ?

C'est exactement ce que je souhaitais... et ça me permettrai d'étudier cela.

Ce serait super cool de ta part !

Par avance merci

A+

[ilank]

Bonjour,
ça va être un peu compliqué pour te fournir le code tout de suite car j'ai utilisé plusieurs modules pour les test et il faut que je regroupe l'ensemble.

[ilank]

Bonjour,

mieux vaut tard que jamais

Voici le code à placer dans un nouveau module de Classe nommé clToolTip

Code :

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
 
Option Compare Database
Option Explicit
' ================================================================================================================================================
'|| Module       : clToolTip
'|| Créé le      : 20-11-2010
'|| Auteur       : Ilank
'|| Modifié le   :
'|| Rôle         : ToolTip pour liste d'une zone de liste déroulante
'||
'||------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'||
'|| Tables       : (aucune)
'|| Objets       : (aucun)
'|| Formulaires  :
'|| Menus        : (aucun)
' ================================================================================================================================================
' ================================================================================================================================================
'||  Data Section : CONSTANTES
' ================================================================================================================================================
Const CW_USEDEFAULT = &H80000000
Const TOOLTIP_CLASS = "tooltips_class32"
Const TITLE = "Exemple de ToolTip IlanK"
Const apiTRUE = 1
Const apiFALSE = 0
Const WM_USER = &H400
Const CCM_FIRST = &H2000
' ================================================================================================================================================
'||  Data Section : ENUMERATIONS (constantes)
' ================================================================================================================================================
Private Enum WINDOW_STYLE_FLAG
    WS_POPUP = &H80000000
    WS_VISIBLE = &H10000000
End Enum
 
Private Enum WINDOW_STYLE_EX_FLAG
    WS_EX_TOPMOST = &H8
    WS_EX_TOOLWINDOW = &H80
End Enum
 
Private Enum GET_WINDOW_LONG_FLAG
    GWL_STYLE = -16
    GWL_EXSTYLE = -20
    GWL_WNDPROC = -4
    GWL_HINSTANCE = -6
    GWL_HWNDPARENT = -8
    GWL_USERDATA = -21
    GWL_ID = -12
End Enum
 
Private Enum TOOLTIP_STYLE_FLAG
    TTS_ALWAYSTIP = &H1
    TTS_NOPREFIX = &H2
    TTS_NOANIMATE = &H10
    TTS_NOFADE = &H20
    TTS_BALLOON = &H40
    TTS_USEVISUALSTYLE = &H100 'uniquement sous Windows XP et au-dessus
End Enum
 
Private Enum TOOLTIP_TOOL_FLAG
    TTF_IDISHWND = &H1
    TTF_CENTERTIP = &H2
    TTF_RTLREADING = &H4
    TTF_SUBCLASS = &H10
    TTF_TRACK = &H20
    TTF_ABSOLUTE = &H80
    TTF_TRANSPARENT = &H100
    TTF_DI_SETITEM = &H8000
End Enum
 
Private Enum TOOLTIP_TITLEICON_FLAG
    TTI_NONE = 0
    TTI_INFO = 1
    TTI_WARNING = 2
    TTI_ERROR = 3
End Enum
 
Private Enum TOOLTIP_DELAYTIME_FLAG
    TTDT_AUTOMATIC = 0
    TTDT_RESHOW = 1
    TTDT_AUTOPOP = 2
    TTDT_INITIAL = 3
End Enum
 
Private Enum TOOLTIP_MESSAGE_FLAG
    TTM_ACTIVATE = WM_USER + 1
    TTM_SETDELAYTIME = WM_USER + 3
    TTM_ADDTOOL = WM_USER + 4
    TTM_DELTOOL = WM_USER + 5
    TTM_NEWTOOLRECT = WM_USER + 6
    TTM_RELAYEVENT = WM_USER + 7
    TTM_GETTOOLINFO = WM_USER + 8
    TTM_SETTOOLINFO = WM_USER + 9
    TTM_HITTEST = WM_USER + 10
    TTM_GETTEXT = WM_USER + 11
    TTM_UPDATETIPTEXT = WM_USER + 12
    TTM_GETTOOLCOUNT = WM_USER + 13
    TTM_ENUMTOOLS = WM_USER + 14
    TTM_GETCURRENTTOOL = WM_USER + 15
    TTM_WINDOWFROMPOINT = WM_USER + 16
    TTM_TRACKACTIVATE = WM_USER + 17
    TTM_TRACKPOSITION = WM_USER + 18
    TTM_SETTIPBKCOLOR = WM_USER + 19
    TTM_SETTIPTEXTCOLOR = WM_USER + 20
    TTM_GETDELAYTIME = WM_USER + 21
    TTM_GETTIPBKCOLOR = WM_USER + 22
    TTM_GETTIPTEXTCOLOR = WM_USER + 23
    TTM_SETMAXTIPWIDTH = WM_USER + 24
    TTM_GETMAXTIPWIDTH = WM_USER + 25
    TTM_SETMARGIN = WM_USER + 26
    TTM_GETMARGIN = WM_USER + 27
    TTM_POP = WM_USER + 28
    TTM_GETBUBBLESIZE = WM_USER + 30
    TTM_ADJUSTRECT = WM_USER + 31
    TTM_SETTITLE = WM_USER + 32
    TTM_SETTITLEW = WM_USER + 33
    TTM_POPUP = WM_USER + 34
    TTM_ADDTOOLW = WM_USER + 50
    TTM_DELTOOLW = WM_USER + 51
    TTM_NEWTOOLRECTW = WM_USER + 52
    TTM_GETTOOLINFOW = WM_USER + 53
    TTM_SETTOOLINFOW = WM_USER + 54
    TTM_HITTESTW = WM_USER + 55
    TTM_GETTEXTW = WM_USER + 56
    TTM_UPDATETIPTEXTW = WM_USER + 57
    TTM_ENUMTOOLSW = WM_USER + 58
    TTM_GETCURRENTTOOLW = WM_USER + 59
    TTM_SETWINDOWTHEME = CCM_FIRST + &HB
End Enum
' ================================================================================================================================================
'||  Data Section : STRUCTURES
' ================================================================================================================================================
Private Type INT64
    value As Double
End Type
 
Private Type INT32
    value As Long
End Type
 
Private Type DSHORT
    shortLow As Integer
    shortHigh As Integer
End Type
 
Private Type POINT
    X As Long
    Y As Long
End Type
 
Private Type RECT
    rctLEFT As Long
    rctTOP As Long
    rctRIGHT As Long
    rctBOTTOM As Long
End Type
 
Private Type TOOLINFO
  cbSize As Long
  uFlags As TOOLTIP_TOOL_FLAG
  hWnd As Long
  uId As Long
  arect As RECT
  hinst As Long
  lpszText As String
  lParam As Long
  lpReserved As Long
End Type
' ================================================================================================================================================
'||  Data Section : API
' ================================================================================================================================================
Private Declare Function WindowFromPoint Lib "user32" (ByVal ptrPOINT As Double) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwStyleEx As Long, ByVal lpszClassName As String, ByVal lpszWindowName 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, lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd 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 GetCursorPos Lib "user32" (ByRef lpPOINT As POINT) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GET_WINDOW_LONG_FLAG) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByVal lpRect As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As TOOLTIP_MESSAGE_FLAG, ByVal wParam As Long, ByVal lParam As Long) As Long
'-------------------------------------------------------------------------------------------------------------------------------------------------
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, lpIacc As IAccessible, pvarchild As Variant) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal lpIacc As IAccessible, ByVal ptrhWnd As Long) As Long
' ================================================================================================================================================
'||  Data Section : VARIABLES
' ================================================================================================================================================
Private hWndTip As Long
Private hWndCbb As Long
Private hWndCbbList As Long
Private cursorPos As POINT
Private ttInfo As TOOLINFO
Private columnIndex As Long
Private WithEvents ttCombobox As Access.ComboBox
' ================================================================================================================================================
'||  Code Section :
' ================================================================================================================================================
 
Public Sub Initiate(ByRef Ctrl As Access.ComboBox, cIndex As Long)
    Set ttCombobox = Ctrl
    columnIndex = cIndex
    ttCombobox.OnMouseMove = "[Event procedure]"
    Ctrl.SetFocus
    hWndCbb = GetFocus()
End Sub
 
Public Function CreateToolTip(hWndList As Long) As Long
    Dim apiERROR As Long
    Dim dwStyleEx As WINDOW_STYLE_EX_FLAG
    Dim dwStyle As WINDOW_STYLE_FLAG
    dwStyleEx = WS_EX_TOPMOST  'Non obligatoire une fenêtre de classe TOOLTIP_CLASS a toujours ces valeurs pour style étendu
    dwStyle = WS_POPUP Or TTS_ALWAYSTIP Or TTS_USEVISUALSTYLE
    If hWndTip = 0 Then
        hWndTip = CreateWindowEx(dwStyleEx, TOOLTIP_CLASS, vbNullString, dwStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, ttCombobox.Parent.hWnd, 0, GetAppInstance(), vbNull)
        AddTool hWndList
    End If
End Function
 
Public Function DisposeToolTip()
    Dim apiERROR As Long
    If hWndTip <> 0 Then
     apiERROR = DestroyWindow(hWndTip)
     hWndTip = 0
   End If
End Function
 
Private Function AddTool(ByVal hWnd As Long) As Boolean
    Dim apiERROR As Long
    With ttInfo
        .cbSize = Len(ttInfo)
        .uFlags = TTF_SUBCLASS
        .hinst = GetAppInstance()
        .hWnd = hWnd
        .arect = GetCtrlRect(hWnd)
        .arect.rctRIGHT = .arect.rctRIGHT - .arect.rctLEFT
        .arect.rctBOTTOM = .arect.rctBOTTOM - .arect.rctTOP
        .arect.rctLEFT = 0: .arect.rctTOP = 0
        .lpszText = ttCombobox.column(columnIndex, ttCombobox.accHitTest(cursorPos.X, cursorPos.Y))
    End With
    AddTool = CBool(SendMessage(hWndTip, TTM_ADDTOOL, 0, VarPtr(ttInfo)))
    apiERROR = SendMessage(hWndTip, TTM_SETTITLEW, TTI_INFO, StrPtr(TITLE))
    apiERROR = SendMessage(hWndTip, TTM_ACTIVATE, apiTRUE, 0)
    apiERROR = SendMessage(hWndTip, TTM_TRACKACTIVATE, apiTRUE, 0)
End Function
 
Private Function RemoveTool(ByVal hWnd As Long) As Boolean
    Dim apiERROR As Long
    With ttInfo
        .cbSize = Len(ttInfo)
        .hWnd = hWnd
        .uFlags = TTF_SUBCLASS
    End With
    apiERROR = SendMessage(hWndTip, TTM_DELTOOL, 0, VarPtr(ttInfo))
End Function
 
Private Function RefreshToolTip(hWnd As Long)
    Dim apiERROR As Long
    If ttInfo.cbSize = 0 Then AddTool (hWnd)
    ttInfo.hinst = GetAppInstance()
    ttInfo.uFlags = TTF_SUBCLASS
    ttInfo.lpszText = ttCombobox.column(columnIndex, ttCombobox.accHitTest(cursorPos.X, cursorPos.Y))
    apiERROR = SendMessage(hWndTip, TTM_UPDATETIPTEXTW, 0, VarPtr(ttInfo))
    apiERROR = SendMessage(hWndTip, TTM_TRACKPOSITION, 0, MAKELPARAM(cursorPos.X, cursorPos.X))
End Function
 
Private Function MAKELPARAM(dwLow As Long, dwHigh As Long) As Long
    Dim dwValue As INT32
    Dim longInt As DSHORT
    Dim retLong As DSHORT
    dwValue.value = dwLow
    LSet longInt = dwValue
    dwValue.value = dwHigh
    LSet retLong = dwValue
    retLong.shortHigh = retLong.shortLow
    retLong.shortLow = longInt.shortLow
    LSet dwValue = retLong
    MAKELPARAM = dwValue.value
End Function
 
Private Function shl(Nombre As Long, decalage As Byte) As Long
    shl = Nombre * (2 ^ decalage)
End Function
 
Public Function GetAppInstance() As Long
    GetAppInstance = GetWindowLong(hWndAccessApp, GWL_HINSTANCE)
End Function
 
Private Function GetCtrlRect(ByVal hWnd As Long) As RECT
    Dim apiERROR As Long
    Dim ptrRECT As RECT
    If hWnd <> 0 Then
        apiERROR = GetWindowRect(hWnd, VarPtr(ptrRECT))
    End If
    GetCtrlRect = ptrRECT
End Function
 
Public Function GethWndFromCursor() As Long
    Dim apiERROR As Long
    Dim hWndLst As Long
    Dim IAcc As IAccessible
    apiERROR = GetCursorPos(cursorPos)
    AccessibleObjectFromPoint cursorPos.X, cursorPos.Y, IAcc, 0&
    If IAcc.accHitTest(cursorPos.X, cursorPos.Y) = 0 Then
        apiERROR = WindowFromAccessibleObject(IAcc, VarPtr(hWndLst))
    End If
    GethWndFromCursor = hWndLst
End Function
 
Public Function GetWindowClass(ByVal hWnd As Long) As String
    Dim buffer As String
    Dim BufferSize As Long
    buffer = Space(255)
    BufferSize = GetClassName(hWnd, buffer, Len(buffer))
    If BufferSize Then
        GetWindowClass = Left(buffer, BufferSize)
    End If
End Function
 
Private Sub Class_Terminate()
    DisposeToolTip
End Sub
 
Private Sub ttCombobox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo mousemove_erreur
    Dim hWndLst As Long
    Dim apiERROR As Long
    hWndLst = GethWndFromCursor
    ttCombobox.accHitTest cursorPos.X, cursorPos.Y
    If hWndLst <> 0 Then
        If hWndLst <> hWndCbb Then
            If hWndTip = 0 Then
                CreateToolTip hWndLst
                hWndCbbList = hWndLst
            Else
                If hWndLst <> hWndCbbList Then
                    DisposeToolTip
                    CreateToolTip hWndLst
                    hWndCbbList = hWndLst
                Else
                    RefreshToolTip hWndLst
                End If
            End If
        End If
    End If
mousemove_erreur:
End Sub

Exemple d'utilisation de clToolTip

Code :

1
2
3
4
5
 
Dim MyToolTip as clToolTip
Private Sub Form_Load()
 Set MyToolTip=new clToolTip
 MyToolTip.Initiate NomDeLaCombobox, IndiceDeLaColonneaAfficher