Discussion :

[pijaku]

Bonjour à toutes et tous,

La présente contribution est le fruit de la collaboration de deux membres : unparia et moi-même.

L'idée maîtresse est d'ajuster in fine par glissements en boucle et de limiter le nombre de ces déplacements par un pré-positionnement.
__________________________________________________________

Pourquoi cette contribution ?
Elle est la suite/solution à un problème ayant récemment donné lieu à une très (bien trop) longue discussion concernant la détermination précise des coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel spécifiée, quels que puissent être :

1. la configuration du client en matière de DPI
2. le facteur de zoom
3. la disposition d'affichage de la fenêtre application et de la fenêtre "active" (qui contient la grille)

Liminaire :

• De très nombreuses tentatives ont été conduites par plusieurs développeurs en vue de déterminer ces coordonnées par calculs. Certaines avec plus de succès que d'autres, mais aucune n'atteignant la perfection. Les meilleures d'entre elles se sont heurtées à des problèmes conjugués :
  - difficultés de la méthode PointsToScreenPixels à tout intégrer lorsqu'appliquée à des coordonnées de cellule,
  - difficultés nécessitant des corrections se heurtant elles-mêmes à des problèmes d'arrondis et de "cadences" des dimensions de cellules en fonction du DPI.
  Des calculs poussés ont permis de réduire à peau de chagrin des décalages observés dans certains cas, mais, mêmes très infimes, ces décalages restaient légèrement perceptibles en facteur élevé de zoom.
  
• la méthode et le code finalement retenus (par glissements) donnent d'excellents résultats

La méthode :
Elle est on ne peut plus simple.
Sans aucune détermination du DPI, sans tenir compte du facteur de zoom, et en ne faisant appel à aucune fonction de l'API Windows si ce n'est SetCursorPos pour placer le curseur...

1. On détermine le point de départ, grâce à la méthode PointsToScreenPixels, sur le coin supérieur gauche (approximatif) de la cellule,
2. On décale ce point de départ, le cas échéant, de 5 pixels vers le haut et/ou vers la gauche,
3. On décale ce nouveau point, par pas de 1 (d'abord en Left, puis en Top), jusqu'à parvenir au bon endroit. Pour le vérifier, on utilise la méthode RangeFromPoint.

IMPORTANT :
L'unique vocation de la présente contribution est la détermination des coordonnées/écran, en pixels, du coin supérieur gauche d'une cellule spécifiée.
Nous serions Jacques (unparia) et moi-même reconnaissants à tout visiteur d'éviter de poser ici des questions quant à l'utilisation des coordonnées ainsi extraites.
S'ils en éprouvent le besoin, il peuvent ouvrir une discussion à ce sujet, genre (exemple) :
"Je souhaiterais placer un userform (ou autre chose) de telle manière que son coin supérieur gauche soit placé à des coordonnées/écran que j'ai déterminées en pixels".

Merci de veiller à respecter cette manière de sérier les problèmes.

__________________________________________________________

Le code :

Dans un module standard :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 
Public Type Position
    Left As Integer
    Top As Integer
End Type
 
Private Const GARDEFOU As Byte = 20
 
Private Const PARDEFAUT_X As Integer = 0    ' A ADAPTER
Private Const PARDEFAUT_Y As Integer = 0    ' A ADAPTER
 
Public Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True) As Position
Dim cel As Range, cc As Byte, cr As Byte, L As Integer, T As Integer, IniL As Integer, IniT As Integer
 
    With LePane
        If Rng.Column = .ScrollColumn Then cc = 0 Else cc = 5
        If Rng.Row = .ScrollRow Then cr = 0 Else cr = 5
        L = .PointsToScreenPixelsX(Rng.Left) - cc: IniL = L
        T = .PointsToScreenPixelsY(Rng.Top) - cr: IniT = T
        On Error Resume Next
        Set cel = ActiveWindow.RangeFromPoint(L, T)
        Do Until cel.Left >= Rng.Left
            L = L + 1
            If L > IniL + GARDEFOU Then GoTo BoucleInfinie
            Set cel = ActiveWindow.RangeFromPoint(L, T)
        Loop
        Do Until cel.Top >= Rng.Top
            T = T + 1
            If T > IniT + GARDEFOU Then GoTo BoucleInfinie
            Set cel = ActiveWindow.RangeFromPoint(L, T)
        Loop
        Set cel = Nothing
    End With
    TopLeftCellule.Left = IIf(DansLaCellule, L, L - 1)
    TopLeftCellule.Top = IIf(DansLaCellule, T, T - 1)
    Exit Function
BoucleInfinie:
    With LePane
        TopLeftCellule.Left = .PointsToScreenPixelsX(PARDEFAUT_X)
        TopLeftCellule.Top = .PointsToScreenPixelsY(PARDEFAUT_Y)
        MsgBox "Conditions impossibles pour le positionnement du curseur"
    End With
End Function
 
Public Function QuelPane(ByVal T As Range, Optional ByVal ActivationFeuil As Boolean = False) As Pane
Dim LngNbPanes As Long, LngPane As Long
 
    If ActiveWindow.VisibleRange.Worksheet.Parent.Name = T.Worksheet.Parent.Name Then
        If ActiveWindow.ActiveSheet.Name = T.Worksheet.Name Or ActivationFeuil Then
            T.Worksheet.Activate
            LngNbPanes = ActiveWindow.Panes.Count
            For LngPane = 1 To LngNbPanes
                With ActiveWindow.Panes(LngPane)
                    If Not Intersect(T, .VisibleRange) Is Nothing Then
                        Set QuelPane = ActiveWindow.Panes(LngPane)
                        Exit Function
                    End If
                End With
            Next
        End If
    End If
    Set QuelPane = Nothing
End Function

Exemples d'appels :

1- Depuis un module standard :
Pour positionner le curseur dans le coin supérieur gauche de la cellule Q2 en feuille Feuil3***, alors que la Feuil1 est active :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Option Explicit
 
Public Sub Place_Curseur()
Dim Cellule As Range, PosCur As Position, P As Pane
 
    Set Cellule = Sheets("Feuil3").Range("Q2")
    Set P = QuelPane(Cellule, True)
    If Not P Is Nothing Then
        PosCur = TopLeftCellule(P, Cellule, False)
        SetCursorPos PosCur.Left, PosCur.Top
    End If
    Set Cellule = Nothing
    Set P = Nothing
End Sub

***Remarque : Si la cellule Q2 ne fait pas partie du VisibleRange de la Feuil3, vous accéderez à la feuille, mais sans positionner le curseur.

2- Depuis un événement de feuille :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Option Explicit
 
'Appel depuis le module de la feuille
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim PosCur As Position, P As Pane
 
    Set P = QuelPane(Target)
    If Not P Is Nothing Then
        PosCur = TopLeftCellule(P, Target, False)
        SetCursorPos PosCur.Left, PosCur.Top
    End If
    Set P = Nothing
End Sub

__________________________________________________________

Conclusion :
Merci de vous être intéressés à notre travail.
Le code est très peu commenté (voir pas du tout...), par conséquent, n'hésitez pas à nous poser toutes vos éventuelles questions.
Jacques et moi vous répondrons avec plaisir.

[lu76fer]

Bonjour à vous !
J'ai testé le code sous Excel 2003 et il s'avère que la fonction PointsToScreenPixelsX n'était pas disponible pour l'objet Pane,
du coup je me demandait à partir de quelle version cette fonction a été ajoutée pour l'objet Pane ?
J'ai testé sous Excel 2016 et cette fois-ci c'est la déclaration de SetCursor qui ne passe pas alors il est peut-être préférable
pour la compatibilité de déclaré ainsi :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
#If VBA7 Then
    Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#Else
    Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#End If

Un travail Intéressant ! Merci à vous

[PHDVFSM]

Le sujet date un peu et pour cause, utilisant la version d'Excel 2003 je ne savais pas que dans la version d'Excel 2007 (je répond à ma propre question) une nouvelle fonction PointsToScreenPixelsX et ...Y avait été ajouté et répond directement au sujet de cette discussion qui en faite n'a lieu d'être que pour la version d'Excel 2003. Malheureusement, cette contribution, à la suite de 46 pages d'échange sur le sujet n'y répond pas non plus

Je propose une optimisation de la fonction 'TopLeftCellule' :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Public Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True) As Position
Dim L As Integer, T As Integer
Dim totIt As Long
    With LePane
        L = .PointsToScreenPixelsX(Rng.Left)
        T = .PointsToScreenPixelsY(Rng.Top)
    End With
    TopLeftCellule.Left = IIf(DansLaCellule, L, L - 1)
    TopLeftCellule.Top = IIf(DansLaCellule, T, T - 1)
End Function

On remarque que la nouvelle fonction associée à l'objet Pane répond parfaitement au sujet depuis la version Excel 2007 :
La détermination des coordonnées/écran, en pixels, du coin supérieur gauche d'une cellule spécifiée

[lu76fer]

Du coup la fonction PointToScreenXouY marcherait parfaitement, et la fonction TopLeftCellule développée plus haut ne ferait qu'introduire une erreur de 5 puis la corrigée petit à petit (1) au sein d'une boucle !!
Qui plus ait en ils feraient un appel à une fonction RangeFromPoint de façon totalement inutile .
Cela mériterait au moins une explication, voir une remise en cause ...

[PHDVFSM]

Il est a noté parfois une petite imprécision dans le calcul de la fonction PointsToScreenPixelsXouY lorsque l'on exploite le zoom qui introduit des imprécisions mais il n'est pas sûr que 5 pixels soit réellement utile mais plutôt 1 pixel d'erreur ... A tester.
Cela reste un bon travail !

[lu76fer]

Après avoir tester la fonction je me suis rendu compte quel pouvait présenter 2 à 3% de cas ou elle n'ait pas capable de déterminer la position...
En évitant de décaler, comme dans votre algo, le point déterminer au départ par la fonction PointsToScreenPixelsXouY j'améliore la performance de l'algo.
Le principe est de chercher la position dans la même boucle et de traiter le cas d'erreur ou RangeFromPoint renvoie Nothing.
Si dès le départ RangeFromPoint renvoie Nothing l'algo va permettre de se rapprocher de la grille en diagonale et non de façon rectiligne ce qui évite les 2 à 3% d'échec de la fonction.
Voici la fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Public Function GetScreenGridPos(ByVal noPane As Integer, ByVal cellTopLeft As Range) As ScreenPos
Dim cel As Range, x As Long, y As Long, crtPane As Pane
Dim wayHor As Integer, wayVert As Integer, state As Byte, totIt As Byte
    Set crtPane = ActiveWindow.Panes(noPane)
    With crtPane
        'Repérer la 1ère ligne et la 1ère colonne du volet
        wayHor = IIf(cellTopLeft.Column = .ScrollColumn, 1, -1)   'Sens Hor
        wayVert = IIf(cellTopLeft.row = .ScrollRow, 1, -1)    'Sens Vert
        x = .PointsToScreenPixelsX(cellTopLeft.Left)
        y = .PointsToScreenPixelsY(cellTopLeft.Top)
        Do
            Set cel = ActiveWindow.RangeFromPoint(x, y)
            If cel Is Nothing Then
                If (state And 2) Then state = state + 2
                x = x + wayHor: y = y + wayVert
            Else
                If state < 3 Then
                    If cel.Left < cellTopLeft.Left Then
                        state = IIf(state = 2, 4, 1)
                        x = x + 1
                    Else
                        Select Case state
                        Case 0: wayHor = 1: wayVert = 0: state = 2
                        Case 1: state = 4
                        Case 2: x = x - 1
                        End Select
                    End If
                End If
                If state > 3 Then
                    If cel.Top < cellTopLeft.Top Then
                        state = IIf(state = 6, 8, 5)
                        y = y + 1
                    Else
                        Select Case state
                        Case 4: wayHor = 0: wayVert = 1: state = 6
                        Case 5: state = 8
                        Case 6: y = y - 1
                        End Select
                    End If
                End If
            End If
            totIt = totIt + 1: If totIt = 20 Then state = 9
        Loop Until state > 7
    End With
    'State = 9 : retour=(0,0)
    GetScreenGridPos.x = IIf(state = 8, x, 0)
    GetScreenGridPos.y = IIf(state = 8, y, 0)
End Function

Ce n'est pas tout à fait la même fonction car les paramètres d'entrées et sortie change un peu.
Je propose aussi une version compatible aussi avec Excel 2003 utilisant window.PointsToScreenPixelsX étant donné que pane.PointsToScreenPixelsX n'était pas disponible dans celle-ci.

Voici le lien vers une démo qui permet de tester cette fonction avec un menu contextuel et un Userform :
Démo pour positionner un UserForm ou ContextMenu sur la grille (Toute version)