XL 2016 VBA - Exact Visible Range

[Dudu2]

Bonjour,

VBA nous donne un Window.VisibleRange qui inclut les dernières colonne et ligne pas forcément complètement visibles.
C'est souvent handicapant quand on veut avoir un Window.ExactVisibleRange qui exclut les parties non visibles des dernières colonne et ligne.

J'ai dû faire un code sans trop d'API pour tenter de définir cet ExactVisibleRange mais hélas, j'ai aussi dû utiliser des constantes qui semblent valides chez moi. Mais le sont-elles chez vous ?

Const VerticalScrollBarBordersPixels As Long = 2 * 2.5    'Borders around the Vertical Scroll Bar
Const HorizontalScrollBarBordersPixels As Long = 2 * 4    'Borders around the Horizontal Scroll Bar
Const StatusBarHeightPixels = 26

Merci par avance de tester ce code pour vérifier qu'en toutes configurations de fenêtre (maximisée et réduite), la Shape Rectangle s'affiche bien aux limites basses de la partie visible.
Si ce n'est pas le cas, un petit screenshot et des infos sur la version Window et Office (versions et bits)

Fichier: voir plus loin

 

[Dudu2]

toujours pareil en mode maximisé sans les displays, tu est trop large de 10 points a peu près

10 points, c'est énorme, je me demande où est le surplus, difficile à vérifier sans tester sur la config.
Je pense qu'il y a une différence majeure entre nos 2 configs.

 

[patricktoulon]

Allez tu va trouvé ça loufoque mais je fait un 100% exact a tout les coups sur mes 3 versions win/office

Sub test()
   'idée et creation de patricktoulon the best of the bidoudouille :):):)
  
   ' Dim G#, T#, Vr As Range, LastCell As Range, D#, B#, Large#, Hauteur#, shap As Shape

    'supprime la shape si elle existe
    On Error Resume Next
    ActiveSheet.Shapes("cobaie").Delete
    On Error GoTo 0

    With ActiveWindow.Panes(1)

        G = .PointsToScreenPixelsX(0) 'point gauche de depart(base ecran en pixel)
        T = .PointsToScreenPixelsY(0) 'point top de depart(base ecran en pixel)

        Set Vr = .VisibleRange 'range visible

        Set LastCell = Vr.Cells(Vr.Cells.Count).Offset(-1, -1) 'avant dernière cellule du visiblerange

        D = .PointsToScreenPixelsX(LastCell.Left) '.left de cette cellule(base ecran en pixel)
        B = .PointsToScreenPixelsY(LastCell.Top) '.top de cette cellule(base ecran en pixel)

        'on boucle vers le bas tant que rangefrompoint donne un range
        Do While TypeName(.Parent.RangeFromPoint(D, B)) = "Range": B = B + 1: DoEvents: Loop
        B = B - 1 'on est sorti on revient de 1

        'on boucle vers la droite tant que rangefrompoint donne un range
        Do While TypeName(.Parent.RangeFromPoint(D, B)) = "Range": D = D + 1: DoEvents: Loop
        D = D - 1 ' on revient de 1

        Large = (D - G) * 0.75 ' la droite - la gauche en point
        Hauteur = (B - T) * 0.75 ' le bas - le top en point
        'ajoute la shape aux dimensions


        DoEvents
        Set shap = ActiveSheet.Shapes.AddShape(1, 0, 0, Large, Hauteur)

        shap.Name = "cobaie"
        shap.Fill.Transparency = 0.5
    End With

    'ET CEST NICKEL!!!!!!!!!!!!!!
End Sub

 

[TooFatBoy]

@TooFatBoy et @patricktoulon, merci d'essayer chez vous

En fenêtre flottante le cadre rouge descend un pixel trop bas.

En plein écran c'est pire : on ne voit plus le trait du bas.

 

[patricktoulon]

et au cas ou il y aurais un object quelconque (shape activX ou autre dans l'angle en bas a droite
on teste le nothing qui ne peut être donné que quand les point sont hors de la grille

Sub test()
    Dim G#, T#, Vr As Range, LastCell As Range, D#, B#, Large#, Hauteur#, shap As Shape

    'supprime la shape si elle existe
    On Error Resume Next
    ActiveSheet.Shapes("cobaie").Delete
    On Error GoTo 0

    With ActiveWindow.Panes(1)

        G = .PointsToScreenPixelsX(0) 'point gauche de depart(base ecran en pixel)
        T = .PointsToScreenPixelsY(0) 'point top de depart(base ecran en pixel)

        Set Vr = .VisibleRange 'range visible

        Set LastCell = Vr.Cells(Vr.Cells.Count).Offset(-1, -1) 'avant dernière cellule du visiblerange

        D = .PointsToScreenPixelsX(LastCell.Left) '.left de cette cellule(base ecran en pixel)
        B = .PointsToScreenPixelsY(LastCell.Top) '.top de cette cellule(base ecran en pixel)
    
        'on boucle vers le bas tant que rangefrompoint ne donne pas nothing
        Do While Not .Parent.RangeFromPoint(D, B) Is Nothing: B = B + 1: DoEvents: Loop
        B = B - 1 'on est sorti on revient de 1

        'on boucle vers la droite tant que rangefrompoint ne donne pas nothing
        Do While Not .Parent.RangeFromPoint(D, B) Is Nothing: D = D + 1: DoEvents: Loop
        D = D - 1 ' on revient de 1

        Large = (D - G) * 0.75 ' la droite - la gauche en point
        Hauteur = (B - T) * 0.75 ' le bas - le top en point
        'ajoute la shape aux dimensions


        DoEvents
        Set shap = ActiveSheet.Shapes.AddShape(1, 0, 0, Large, Hauteur)

        shap.Name = "cobaie"
        shap.Fill.Transparency = 0.5
    End With

    'ET CEST NICKEL!!!!!!!!!!!!!!
End Sub

c'est tout simplement impossible de faire une erreur on travaille au pixel près
et sur les hauteur *2 des cellule max du bottom de la grille en pixels
et pareil pour le width

oserais dire aussi que cette méthode n'a rien a faire que les display soit à true ou à false
je teste même pas c'est pas la peine ca sera juste j'en suis sur

 

[patricktoulon]

et transformé en fonction ça donne ça
la fonction renvoi un array (large,hauteur)

Sub test()
    Dim shap As Shape, dims
    dims = ExactVisibleRangeVpat2
    'supprime la shape si elle existe
    On Error Resume Next
    ActiveSheet.Shapes("cobaie").Delete
    On Error GoTo 0
    DoEvents
    Set shap = ActiveSheet.Shapes.AddShape(1, 0, 0, dims(0), dims(1))
    shap.Name = "cobaie"
    shap.Fill.Transparency = 0.5
End Sub


Function ExactVisibleRangeVpat2()
   'fonction created by patricktoulon
   Dim G#, T#, Vr As Range, LastCell As Range, D#, B#, Large#, Hauteur#
    With ActiveWindow.Panes(1)

        G = .PointsToScreenPixelsX(0) 'point gauche de depart(base ecran en pixel)
        T = .PointsToScreenPixelsY(0) 'point top de depart(base ecran en pixel)

        Set Vr = .VisibleRange 'range visible

        Set LastCell = Vr.Cells(Vr.Cells.Count).Offset(-1, -1) 'avant dernière cellule du visiblerange

        D = .PointsToScreenPixelsX(LastCell.Left) '.left de cette cellule(base ecran en pixel)
        B = .PointsToScreenPixelsY(LastCell.Top) '.top de cette cellule(base ecran en pixel)

        'on boucle vers le bas tant que rangefrompoint ne donne pas nothing
        Do While Not .Parent.RangeFromPoint(D, B) Is Nothing: B = B + 1: DoEvents: Loop
        B = B - 1 'on est sorti on revient de 1

        'on boucle vers la droite tant que rangefrompoint ne donne pas nothing
        Do While Not .Parent.RangeFromPoint(D, B) Is Nothing: D = D + 1: DoEvents: Loop
        D = D - 1 ' on est sorti on revient de 1

        Large = (D - G) * 0.75 ' la droite - la gauche en point
        Hauteur = (B - T) * 0.75 ' le bas - le top en point
       
        ExactVisibleRangeVpat2 = Array(Large, Hauteur)

    End With
 End Function

 

[Dudu2]

Bonjour,
Je suis déçu que mon code ne fonctionne nulle part sauf chez moi .
D'un autre coté, @patricktoulon va pleurer aussi, et bien que son approche soit intéressante et que j'aurais bien aimé que ça fonctionne, ça ne donne rien chez moi.

 

[patricktoulon]

re
il est impossible que ma dernière solution ne fonctionne pas
après c'est pas grave 1 point de trop ou pas assez tes solutions du milieu parmi toute tes versions étaient acceptables
mais ma dernière solution post #80 est pour le coup universelle et fait appel a des object concrets

 

[Dudu2]

En effet, c'est parce que lorsque je change d'échelle d'affichage, il faut relancer le code.
Donc t'as trouvé ! Félicitations !

 

[patricktoulon]

quelle version?

 

[TooFatBoy]

Je suis déçu que mon code ne fonctionne nulle part sauf chez moi .

Moi j'ai l'impression que ça fonctionne chez moi (à un ou deux pixels près).
A moins que je n'ai encore rien compris...

 

[Dudu2]

Mais qu'est-ce que vous faites à 4 heures du mat avec ces foutu pixels ?
Moi j'ai dormi 2h30, ok , je vais y retourner vers 5h30 pour tenter de continuer,

 

[TooFatBoy]

Mais qu'est-ce que vous faites à 4 heures du mat avec ces foutu pixels ?

De la bouillie pour le p'tit dej'.

 

[Dudu2]

Sinon, grâce à la trouvaille de @patricktoulon qui a fait très fort pour trouver une solution dont je finissais par douter, j'ai fait (non sans mal) 2 fonctions:
- ExactVisibleRangeRECTToScreen(): RECT en pixels par rapport à l'écran pour positionner un UserForm par exemple
- ExactVisibleRangeRECTToWindow(): RECT en pixels par rapport à la fenêtre pour positionner une Shape par exemple

J'ai vérifié ExactVisibleRangeRECTToScreen() 100% correct (haut et bas) grâce à la position curseur qui affiche sa croix quand le positionnement est parfait.

Alors une remarque... sur ExactVisibleRangeRECTToWindow() j'ai dû ajouter 2 pixels (SM_CXEDGE, SM_CYEDGE) par rapport à ExactVisibleRangeRECTToScreen() pour avoir la bordure Left et Top de la Shape dans le cadre.

Edit: reste encore à traiter le zoom

 

[TooFatBoy]

Alors une remarque... sur ExactVisibleRangeRECTToWindow() j'ai dû ajouter 2 pixels (SM_CXEDGE, SM_CYEDGE) par rapport à ExactVisibleRangeRECTToScreen() pour avoir la bordure Left et Top de la Shape dans le cadre.

This is perfect !

 

[Dudu2]

En fait le Zoom s'applique non pas sur les RECT des ExactVisibleRange évidemment puisque ce sont des Pixels relatives à l'écran.

Le Zoom s'applique aux objets de la feuille (la Shape par exemple) mais il y a des marges qui apparaissent à cause de l'imprécision du facteur ActiveWindow.Zoom / 100 récupéré par rapport au zoom réel de la feuille.