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 ?

 

[Dudu2]

@cathodique , j'ai modifié le fichier du Post #38 pour (tenter d') éviter cette erreur.
Peux-tu ré-essayer à l'occasion ? Merci.

 

[Dudu2]

Dudu2 ne t'avance pas trop sur les versions d'Excel et les O.S sur lesquels marchent tes classeurs du post #38 sans que quelqu'un ne les ait testés.

Il avait été testé OK par @patricktoulon. Quand ça marche chez lui, ça marche partout 😉.
En plus je fais des hypothèses en attendant un retour d'erreur éventuel car je ne peux pas décemment te demander de vérifier mes fichiers à chaque fois, même si tu le fais volontiers de ta propre initiative, sachant que je devrais installer VirtualBox et toutes les configs ce que je n'ai pas fait.

 

[Rheeem]

Bonjour à tous,
@jurassic pork

Rheeem tu es sûr de ce que tu avances ? parce que j'ai regardé avec FlaUIInspect, il n'y a pas d'objet Bouton Up. Les Seuls objets pour la ListBox sont la ListBox et ses éléments. Le Bouton UP n'est pas accessible.

Oui il y avait des listes qui me renvoie le bouton du scrollbox, en tout cas je ne me rappelle plus avec exactitude sur lesquels mais ce qui est sur j'ai fait également des tests pour les contrôles Excels.

@patricktoulon

"en fait il faut pas "<>0 mais "=0"
car si v=0 ca veut dire qu'il ne capte pas le child (1) en top+4 et right-6"

Désolé c"est un peu bête d'envoyé le code sans le test mais je ne savais pas que la version que j'ai posté ne fonctionne pas,à vrai dire Excel avait planté et le travail est perdu, j'ai recupéré ce qui en reste et je l'ai posté sans tester.

Mais la version Userform à restée intacte c'est elle développée en premier

Private Function HasSb(ByVal Lb As MSForms.ListBox) As Boolean
Dim ac As IAccessible
Dim p(0 To 3) As Long, pz As Long
If Lb.ListCount = 0 Then Exit Function
Set ac = Lb
ac.accLocation p(0), p(1), p(2), p(3), 0&
pz = p(0) + p(2) - 5
HasSb = CInt(ac.accHitTest(pz, p(1) + 5)) = 0
End Function

 

[Rheeem]

@patricktoulon

et là voila au propre avec le getsystemmétric+const scrollbar

Faites attentions avec zoom différent à 100% la taille renvoyé par GetSystemMetrics doit etre aussi ajuster au même zoom.

@Dudu2

Oui mais avec le HitTest on se débarrasse de cette fonction AccessibleObjectFromPoint() dont je ne maîtrise pas bien les déclarations en VBA7 et non-VBA7 et peut-être en Win64 et non-Win64 (le Currency ne me plait guère) ni même l'utilisation. On ne trouve pas d'exemple de déclaration complète de cette fonction sur Internet.

La déclaration correcte pour le paramètre Point pour WindowFromPoint et AccessibleObjectFromPoint devrait être correspondre à un code du genre :

ByVal Point As PointAPI

Mais en VBA il n'est pas possible de passer une structure par valeur donc il faut remplacer par un type de base ayant la même taille que la structure PointAPI (8 octets) pour transporter la valeur du point(aucun calul en currency ou autre n'est fait) donc soit le type LongLong ou Currency ce dernier a l'avantage d'etre présent dans tous les plateformes ca évite l'ecriture de plusieurs versions,,
Avant l'introduction du LongLong le Currency était beaucoup utilisé pour passer les paramètres de int64 sur 8 octets.

Regarder la déclaration des API:
GetDiskFreeSpace
QueryPerformanceFrequency

Cette déclaration pour 32bit est fausse mais fonctionne,, elle exploite une particularité de la convention de passage des paramètres vers la pile STDCALL ou l'argument Point est remplacé par deux arguments de type Long.

Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long

 

[Dudu2]

@Tous,

Faites attentions avec zoom différent à 100% la taille renvoyé par GetSystemMetrics doit etre aussi ajuster au même zoom.

@Rheeem a raison. J'avais tenu compte du Zoom dans une version précédente et là j'ai complètement zappé.
Donc je l'ai ré-introduit.
Attention ! Il y a le Zoom de l'ActiveWindow et le Zoom du UserForm (donc remonter tous les Parents de la ListBox pour trouver le UserForm).

    'Mandatory to avoid a potential wrong result
    If TypeOf ListBox.Parent Is Worksheet Then
        Zoom = ActiveWindow.Zoom / 100
        ListBox.Activate
    Else
        Zoom = GetUserFormFromControl(ListBox).Zoom / 100
        ListBox.SetFocus
    End If

'-------------------------
'Get UserForm from Control
'-------------------------
Private Function GetUserFormFromControl(Control As Object) As Object
    Dim Object As Object
 
    Set Object = Control
    Do While TypeOf Object Is MSForms.Control
        Set Object = Object.Parent
    Loop
 
    Set GetUserFormFromControl = Object
End Function

Par souci de précision, il faut y ajouter les bordures droite et haute selon le SpecialEffect que j'ai testé sur ma config.

    'SpecialEffect Corrections
    Select Case ListBox.SpecialEffect
        Case fmSpecialEffectFlat
            SpecialEffectHCorrectionPixels = 0
            SpecialEffectVCorrectionPixels = 0
    
            'Border Corrections
            If ListBox.BorderStyle = fmBorderStyleSingle Then
                SpecialEffectHCorrectionPixels = 1
                SpecialEffectVCorrectionPixels = 1
            End If
 
        Case Else
            SpecialEffectHCorrectionPixels = 3
            SpecialEffectVCorrectionPixels = 3
    End Select

Le point X, Y visé est donc la moitié de la largeur de la ScrollBar (GetSystemMetrics(SM_CXVSCROLL)) augmentée des corrections SpecialEffect pondérées par le Zoom

    'Coordinates of the Top Right point inside the ListBox potential Vertical Scroll Bar
    X = R.Right - (VerticalScrollBarWidthPixels / 2 + SpecialEffectHCorrectionPixels) * Zoom
    Y = R.Top + (VerticalScrollBarWidthPixels / 2 + SpecialEffectVCorrectionPixels) * Zoom

Mon fichier du Post #38 modifié !

 

[Dudu2]

@Rheeem,
Je sais que la structure utilisateur en ByVal ne passe pas.
Et que Currency est un moyen détourné de passer un argument sur 2 mots, mais à partir du moment où on a LongPtr (ou LongLong)...
Les déclarations de AccessibleObjectFromPoint() telles qu'en Post #92 sont cohérentes avec celles qu'on trouve de WindowFrompoint() sur ce site et d'autres. qui en principe s'appliquent à toutes les plateformes.

 

[jurassic pork]

Mais la version Userform à restée intacte c'est elle développée en premier

Private Function HasSb(ByVal Lb As MSForms.ListBox) As Boolean
Dim ac As IAccessible
Dim p(0 To 3) As Long, pz As Long
If Lb.ListCount = 0 Then Exit Function
Set ac = Lb
ac.accLocation p(0), p(1), p(2), p(3), 0&
pz = p(0) + p(2) - 5
HasSb = CInt(ac.accHitTest(pz, p(1) + 5)) = 0
End Function

Hello,
cette version ne fonctionne pas sous Windows 7 du moins avec Excel 2010, les valeurs renvoyées par accLocation sont toujours toutes égales à 0 pour les ListBox dans une feuille Excel. C'est le même genre de problème qu'avec UIAutomation qui récupère des valeurs qui ne correspondent pas aux coordonnées de la Listbox, avec la propriété currentBoundingRectangle.

@Tous,

@Rheeem a raison. J'avais tenu compte du Zoom dans une version précédente et là j'ai complètement zappé.
Donc je l'ai ré-introduit.
Attention ! Il y a le Zoom de l'ActiveWindow et le Zoom du UserForm (donc remonter tous les Parents de la ListBox pour trouver le UserForm).
Par souci de précision, il faut y ajouter les bordures droite et haute selon le SpecialEffect que j'ai testé sur ma config.
Mon fichier du Post #38 modifié !

J'ai testé le fichier du Post #38 : c'est OK pour un zoom feuille de 50 et un de 150 et aussi pour un zoom formulaire de 50 et de 150 (testé avec Excel 2010 sous windows 7 SP1 avec la modification ci-dessous).
Par contre le fichier du Post #38 ne fonctionne toujours pas dans Windows 7 et c'est "plus grave" qu"avant parce que maintenant il n'y a pas de message d'erreur mais le formulaire Msg ne s'affiche pas si bien que l'on est coincé : il faut aller dans l'Editeur VBA pour arrêter le code.
Une solution en attendant mieux et de remplacer le formulaire Msg par un msgBox si l'O.S est windows 7 :

Sub Display(S As String)
    Msg.SetPositionOnWorksheetObject ActiveSheet.[G17]
    If Right(Application.OperatingSystem, 2) = "01" Then ' "Windows (32-bit) NT 6.01" renvoyé pour Win7
      UserForm1.StartUpPosition = 0: UserForm1.Left = 100: UserForm1.Top = 350 'positionnement Userform1 pas au centre
      MsgBox S
    Else
      Msg.Box S
    End If
End Sub

Ami calmant, J.P

 

[Dudu2]

Bonjour,
@jurassic pork, en principe le bug sur le Application.hWnd du Msg.Box a été corrigé.
Si c'est un problème de cadrage suite au zoom 150%, je sais ce que c'est (**). Sinon je ne vois pas.
Pour sortir du message, comme pour MsgBox, un Escape est suffisant, où que soit l'affichage.

(**) Le code prévoit (par défaut) de garder l'affichage dans la WorkArea du moniteur. Un setting permet d'ignorer ce comportement.
Si ça dépasse en hauteur c'est ajusté de sorte que le message peut-être tronqué.
J'ai modifié le fichier pour afficher le message dans une ligne qui dépend du Zoom pour être sûr de l'avoir dans l'écran.

Edit: D'ailleurs, cette réflexion me fait penser que l'ajustement a la WorkArea n'a de sens qu'en largeur.
En hauteur, réduire le texte ou les boutons n'a pas de sens. Je vais corriger ça.

 

[patricktoulon]

re
bonjour à tous
je l'ai déjà dit à @Dudu2 me semble t il

activeWindow.hwnd ne fonctionne qu'a partir de 2013 et supérieur
en dessous c'est application.hwnd

 

[patricktoulon]

re
perso je me demande ou vous êtes partis
je viens encore de tester à l'instant ma version basé sur l'idée de @Rheeem
et j'ai zoomé le userform à 150
j'ai testé mon code tel quel et il fonctionne très bien
sans avoir a prendre le zoom ou l’éventuelle activation ou prise de focus du control
par contre avec acchittest oui il y a des soucis

pour le zoom dans la feuille je me fait pas de soucis puisque j'utilise pointtoscreenpixels et que les valeur point sont dans le parenthèses de pointstoscreenpixels donc le zoom est pris en compte

sincèrement si ça devient une usine a gaz pour savoir si il y a la scroll ou pas c'est que les outils employés ne sont pas les bons
pour info j'ai testé sur 2016 64 aussi

je redonne mon code au cas ou

'Fonction pour savoir si une listbox a la scrollbar d'affichée ou pas
'patricktoulon
'Rheeem
'jurassic pork
'dudu2
Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal Rw As Currency, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As rect) As Long
#Else
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal Rw As Currency, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As rect) As Long
#End If

Private Const SM_CXVSCROLL = 2
Private Type rect: left As Long: top As Long: right As Long: bottom As Long: End Type
Private Type CPoint: X As Long: Y As Long: End Type
Private Type CRw: Dt As Currency: End Type

Function HasScrollbarVX(ByVal Lb As MSForms.ListBox) As Boolean
    Dim cc As IAccessible, b As CPoint, pz As CRw, v As Variant, retrait&, IAcObj As IAccessible, rc As rect
    retrait = GetSystemMetrics(SM_CXVSCROLL) / 2
    If Lb.ListCount = 0 Then Exit Function
    If TypeOf Lb.Parent Is Worksheet Then
        With ActiveWindow.ActivePane
            b.X = .PointsToScreenPixelsX(Lb.left + Lb.Width - retrait)
            b.Y = .PointsToScreenPixelsY(Lb.top + retrait)
        End With
    Else
        #If VBA7 Then
            Dim Handl As LongPtr
        #Else
            Dim Handl As Long
        #End If
        Set IAcObj = Lb
        WindowFromAccessibleObject IAcObj, Handl
        GetWindowRect Handl, rc
        b.X = rc.right - retrait
        b.Y = rc.top + retrait
    End If
    LSet pz = b
    AccessibleObjectFromPoint pz.Dt, cc, v
    HasScrollbarVX = v = 0
End Function

 

[patricktoulon]

re
j'ai ajouté la lecture du rectangle dans l'userform
et le rectangle est bien lu avec le zoom pris en compte
donc je ne comprends pas votre problème de zoom ni le besoins de s'en préoccuper d'ailleurs

'Fonction pour savoir si une listbox a la scrollbar d'affichée ou pas
'patricktoulon
'Rheeem
'jurassic pork
'dudu2
Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal Rw As Currency, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As rect) As Long
#Else
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal Rw As Currency, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As rect) As Long
#End If

Private Const SM_CXVSCROLL = 2
Private Type rect: left As Long: top As Long: right As Long: bottom As Long: End Type
Private Type CPoint: X As Long: Y As Long: End Type
Private Type CRw: Dt As Currency: End Type

Function HasScrollbarVX(ByVal Lb As MSForms.ListBox) As Boolean
    Dim cc As IAccessible, b As CPoint, pz As CRw, v As Variant, retrait&, IAcObj As IAccessible, rc As rect, q$
    retrait = GetSystemMetrics(SM_CXVSCROLL) / 2
    If Lb.ListCount = 0 Then Exit Function
    If TypeOf Lb.Parent Is Worksheet Then
        With ActiveWindow.ActivePane
            b.X = .PointsToScreenPixelsX(Lb.left + Lb.Width - retrait)
            b.Y = .PointsToScreenPixelsY(Lb.top + retrait)
        End With
    Else
        #If VBA7 Then
            Dim Handl As LongPtr
        #Else
            Dim Handl As Long
        #End If
        Set IAcObj = Lb
        WindowFromAccessibleObject IAcObj, Handl
        GetWindowRect Handl, rc
        With Lb.Parent.TextBox1
            q = "Left : " & rc.left & vbCrLf
            q = q & "Top : " & rc.top & vbCrLf
            q = q & "Right : " & rc.right & vbCrLf
            q = q & "Bottom : " & rc.bottom
            .Value = q
        End With
        b.X = rc.right - retrait
        b.Y = rc.top + retrait
    End If
    LSet pz = b
    AccessibleObjectFromPoint pz.Dt, cc, v
    HasScrollbarVX = v = 0
End Function

 

[Dudu2]

@patricktoulon,
Si ça marche sans correction de zoom, tant mieux, c'est un heureux hasard car le "retrait" tape toujours dans la Scroll Bar pour les zooms testés.
Mais si le zoom réduit la largeur de la Scroll Bar, ce qui me semble être le cas, il est naturel d'essayer de corriger le "retrait" qui est calculé sur la moitié de la largeur de la Scroll Bar (retrait = GetSystemMetrics(SM_CXVSCROLL) / 2).

De toutes façons la prise en compte du zoom représente peu d'instructions, la majorité étant dues à la recherche du UserForm.
En plus, perso, je ne suis pas à la recherche du code la plus concentré possible donc ça ne me gène pas dans la mesure où il y a une justification.

 

[jurassic pork]

et le rectangle est bien lu avec le zoom pris en compte
donc je ne comprends pas votre problème de zoom ni le besoins de s'en préoccuper d'ailleurs

Hello Patrick,
tu ne nous as pas fait le zoom à 50 qui est plus critique (scrollbar plus petite) 😉
Ami calmant, J.P

 

[patricktoulon]

@jurassic pork
la dimension du zoom n'est pas proportionnelle au coeef c'est un arrangement Window
il n'y a que regarder le dessin pour s'en rendre compte
mais bon si vous voulez je prend le zoom
mais je suis quand même étonné de tout ce que vous devez faire pour y arriver
j'ai cru voir un copymemory dans la discussion là ?????????????
tout mes tests me confirment
que la méthode accessibleobjectfrompoint reste la methode la plus sure
la méthode acchittest demande des focus ou activate (va savoir pour quoi) les dimensions ne sont pas tout le temps bien calculées visiblement(testée avec setcursorpos)

sur ce coup la uiautomationclient ben je l'abandonne tout simplement autant il peut être utilise
mais dans ce cas présent trop de divergence (entre version d'excel)

perso :j'ai un raisonnement simple
quand j'ai la méthode et que je vois que je suis obligé de patcher mon raisonnement
(calcul avec d'autre api ,des conditions ,etc...)
c'est que j'utilise pas le bon outils
mais je vous suis en arrière plan je suis curieux de connaitre le code et méthode finale adoptée

 

[Dudu2]

Bonjour à tous,

J'ai hésité à donner suite à cette discussion mais 2 points mentionnés par @patricktoulon méritent des précisions.

j'ai cru voir un copymemory dans la discussion là ?????????????

Oui, et il n'y a rien d'étonnant. En Post #92 j'ai indiqué la déclaration de AccessibleObjectFromPoint() sur le modèle de WindowFrompoint() qu'on trouve ici (ma référence pour les déclarations API) et ici. Alors il y a un copymemory() pour le #Win64, ce n'est pas moi qui l'ai inventé.
Mais si on préfère faire un LSet inspiré par @Rheeem sur une structure contenant un LongLong ou un Currency, c'est aussi possible.

la méthode accessibleobjectfrompoint reste la methode la plus sure
la méthode acchittest demande des focus ou activate (va savoir pour quoi) les dimensions ne sont pas tout le temps bien calculées visiblement(testée avec setcursorpos)

Que ce soit via AccessibleObjectFromPoint() ou via la méthode accHitTest(), on est dans le même contexte IAccessible.
Donc penser que la méthode AccessibleObjectFromPoint() serait la "plus sûre" et dispensée des contraintes de la méthode accHitTest(), sans vérification, est hasardeux comme me l'a justement fait remarquer @jurassic pork.

Si accHitTest() demande un SetFocus pour couvrir des cas marginaux mais réels, AccessibleObjectFromPoint() en a aussi besoin.
Partant du fichier du Post #87, j'y ai introduit le code de @patricktoulon du Post #117. Le résultat est patent, du moins chez moi.

Edit: Pour info, il faut faire le SetFocus avant le WindowFromAccessibleObject() ! Étrange !