XL 2021 VBA - Est-ce que la ListBox a une Scroll Barre Verticale ?

[Dudu2]

Bonjour,

Comment déterminer, à part avec une approximation pas forcément juste sur la Font.Size comme dans l'exemple joint, si une ListBox as une Scroll Barre Verticale ?

 

[Dranreb]

Bonjour.
Je pense que ce ne serait pas gênant de l'initialiser chaque fois dans la fonction. Et ce serait plus pratique à utiliser. Mais … moi non plus je ne connais pas ces objets, ni d'ailleurs quoi que ce soit de la bibliothèque UIAutomationClient, référence "UIAutomationClient", fichier UIAutomationCore.dll

 

[Dudu2]

Salut @jurassic pork,
Ok c'est ce que je pensais et justement je me demandais pourquoi ce n'était pas dans le fonction. Tu l'as expliqué.
Je vais l'essayer avec mon Excel 2021 puisque je crois (?) que UIAutomation c'est à partir de 2016 (cf nos précédentes discussions).

Sinon avec ma méthode "Sélection" j'obtiens un résultat.
Évidemment c'est plus long, une trentaine+ d'instructions (pas du ZIP code ! Donc ça parait "long") mais le diagnostique est 100% correct.

 

[patricktoulon]

Bonjour
juste pour le fun
si on considère que la couleur de la scrollbar ne change jamais elle est donc différente du fond de la listbox
si on considère que l'object est accessible visuellement à l'ecran

Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
'Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long


Sub test()
   Dim obj
   Set obj = ActiveSheet.OLEObjects("ListBox1")
    MsgBox "ListBox1  " & CStr(HasScrollbarV(obj))

    Set obj = ActiveSheet.OLEObjects("ListBox2")
   MsgBox "ListBox2  " & CStr(HasScrollbarV(obj))

End Sub



Function HasScrollbarV(obj) As Boolean
    Dim L1#, L2#, T#
    With ActiveWindow.ActivePane
        L1 = .PointsToScreenPixelsX(obj.Left) + 3
        L2 = .PointsToScreenPixelsX(obj.Left + obj.Width) - 6 ' - .PointsToScreenPixelsX(0)
        T = .PointsToScreenPixelsY(obj.Top) + 50
        c1 = GetPixel(GetDC(0), L1, T)
        c2 = GetPixel(GetDC(0), L2, T)
        If c1 <> c2 Then HasScrollbarV = True
        'SetCursorPos L2, T'juste pour tester ou est vraiment le cursor
    End With
End Function

 

[Dudu2]

En effet, la couleur était une option à envisager si différente de la Back & Fore color de la ListBox.
C'est très rapide comme méthode.

 

[patricktoulon]

re
et un truc encore plus con controler la différence de topx index original avec le topindex - listcount-1
ca implique le changement provisoire du top index mais c'est sans ambiguïté

Sub test22()
 Dim obj
   Set obj = ActiveSheet.OLEObjects("ListBox1")
    MsgBox "ListBox1  " & CStr(HasscrollbarV2(obj))

    Set obj = ActiveSheet.OLEObjects("ListBox2")
   MsgBox "ListBox2  " & CStr(HasscrollbarV2(obj))

End Sub

Function HasscrollbarV2(obj) As Boolean
Dim originalIndex As Long
With obj.Object
    originalIndex = .TopIndex
    .TopIndex = .ListCount - 1
    If .TopIndex <> originalIndex Then HasscrollbarV2 = True
       .TopIndex = originalIndex ' Rétablir l'affichage
End With
End Function

 

[jurassic pork]

Je vais l'essayer avec mon Excel 2021 puisque je crois (?) que UIAutomation c'est à partir de 2016 (cf nos précédentes discussions).

Non non, UIAutomationClient est présent dans windows 7 et je viens d'essayer cela fonctionne avec Excel 2007.

 

[patricktoulon]

re
je viens de voir la méthode avec iaccessible
qui est a peu près le même raisonnement que moi sauf que vous selectez
ce qui veux dire que vous déclenchez à minima l'event click
alors que j'utilise seulement le topindex dans mon model qui ne declenche pas l'event (à méditer)

 

[patricktoulon]

le principe de ma méthode en post #20
on demande le topx index correspondant à la fin de la liste
si il n'y a pas de scrollbar vertical le top index ne changera pas par contre si il y en a une alors le top index va changer
et on remet a la fin le topindex original
Tout simplement 😉
on ne déclenche aucun event de la listbox

c'est selon moi la solution la plus friendly et qui ne demande pas le blocage temporaire des events

 

[jurassic pork]

qui est a peu près le même raisonnement que moi sauf que vous selectez

ben non je ne sélectionne pas, j'affecte un Iaccessible à un contrôle :

Dim OAcc As IAccessible, c As New CUIAutomation, rect As tagRECT
Set OAcc = Feuil1.ListBox1

 

[Dudu2]

Hélas la méthode du test du TopIndex ne fonctionne pas avec le ListBox2

 

[patricktoulon]

re
intéressant ça tiens
je vais regarder

 

[jurassic pork]

Hélas la méthode du test du TopIndex ne fonctionne pas avec le ListBox2

Comme je l'indiquais le cas de la ListBox2 est spécial : tous les éléments de la liste sont visibles mais il y a pourtant un scrollbar vertical cela se joue à quelques pixels près.

 

[Dudu2]

Avec le GetPixel il faut être très très prudent !
Si on passe directement:

GetPixel(GetDC(0), R.Left + 5 , R.Top + 10)

ça part complètement en live, ce qu'on récupère est incertain. J'ai même récupéré du bleu sur la Scroll Bar !

Si on passe:

#If VBA7 Then
    Dim hDC As LongPtr
#Else
    Dim hDC As Long
#End If
    Dim X As Long
    Dim Y As Long
    ...
    hDC = GetDC(0)
    X = R.Left + 5
    Y = R.Top + 10
    ListBoxBackColor = GetPixel(hDC, X, Y)

ça fonctionne un peu mieux !
Mais je récupère des couleurs différentes sur 2 exécutions différentes du même code !

 

[patricktoulon]

re
c'est pour ça que j'utilise pointstoscreenpixel
car avec getwindowrect on est affublé de la marge de dwmapi.dll(DWM)

 

[patricktoulon]

re
re
à essayer chez vous
chez moi j'arrive a capter la différence de 0.5 point soit 0.66.. pixel
testé avec une listbox1 de 137.5 points de height avec 10 items la scrollbar apparait mais n'a pas de course
a 138 points la scrollbar disparait

Sub test33()
 Dim obj
   Set obj = ActiveSheet.OLEObjects("ListBox1")
    MsgBox "ListBox1  " & CStr(HasscrollbarV3(obj))

    Set obj = ActiveSheet.OLEObjects("ListBox2")
   MsgBox "ListBox2  " & CStr(HasscrollbarV2(obj))

End Sub

Function HasscrollbarV3(obj) As Boolean
Dim OldHeight#
Dim lbx As msforms.ListBox
Set lbx = obj.Object
With lbx
   OldHeight = lbx.Height
   .Height = .Font.Size * 1.23 * .ListCount
  If .Height > OldHeight Then HasscrollbarV3 = True
   .Height = OldHeight
   End With
End Function