Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 VBA - Exact Visible Range

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion Dudu2
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

Dudu2

XLDnaute Barbatruc
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 ?
VB: 
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
 
Dernière édition:
Trier par date Trier par votes
Allez tu va trouvé ça loufoque mais je fait un 100% exact a tout les coups sur mes 3 versions win/office

VB: 
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
 
Vote positif 0 Vote négatif
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
VB: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
et transformé en fonction ça donne ça
la fonction renvoi un array (large,hauteur)
VB: 
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
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
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
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
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.
 

Pièces jointes

Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…