Positionner curseur sur une cellule sélectée Windows Excel VBA

Invité · 17/07/2017, 15h01

J'obtiens 8,8,3,1 avec ton test Patrick.

**pijaku** · 17/07/2017, 15h02

Avec aero : 8, 8, 3, 1
Sans aero : 4, 4, 3, 1

**patricktoulon** · 17/07/2017, 15h12

a ben c'est rassurant
prenez la 1 ou la deux et soustrayez lui la 3 et 4 vous avez votre différence

apres je ne sais mais il me semble que c'est retourné en pixel
donc si je fait getsystemmetrics(32 ou 33)/ppx j'obtiens pil poil mon 4.8 qu'il me faut chez moi a 0.000000001 près!!

je suis curieux de connaitre le résultat sur W10

**Nicolas JACQUIN** · 17/07/2017, 16h03

4, 4, 3, 1

**pijaku** · 17/07/2017, 16h27

Attention également à Application.ScreenUpdating...

Je vous remet le code entier du module dûment corrigé :

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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Option Explicit
 
Private Enum DWMWINDOWATTRIBUTE
    DWMWA_NCRENDERING_ENABLED = 1
    DWMWA_NCRENDERING_POLICY
    DWMWA_TRANSITIONS_FORCEDISABLED
    DWMWA_ALLOW_NCPAINT
    DWMWA_CAPTION_BUTTON_BOUNDS
    DWMWA_NONCLIENT_RTL_LAYOUT
    DWMWA_FORCE_ICONIC_REPRESENTATION
    DWMWA_FLIP3D_POLICY
    DWMWA_EXTENDED_FRAME_BOUNDS
    DWMWA_LAST
End Enum
 
Public Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
End Type
 
Private Declare Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Dim Col As Long, Lig As Long
 
Public Function fPosCel(RngTarget As Range) As RECT
Dim LngPane As Long, LngNbPanes As Long, DblPpx As Double, BoolScreenUp As Boolean
 
    If Application.ScreenUpdating = False Then Application.ScreenUpdating = True: BoolScreenUp = True
    DblPpx = fPpx(72)
    LngNbPanes = ActiveWindow.Panes.Count
    For LngPane = 1 To LngNbPanes
        With ActiveWindow.Panes(LngPane)
            If Not Intersect(RngTarget, .VisibleRange) Is Nothing Then
                fPosCel.Left = .PointsToScreenPixelsX(RngTarget.Left) / DblPpx
                fPosCel.Top = .PointsToScreenPixelsY(RngTarget.Top) / DblPpx
                fPosCel.Right = RngTarget.Width
                fPosCel.Bottom = RngTarget.Height
                Exit For
            End If
        End With
    Next
    If BoolScreenUp Then Application.ScreenUpdating = False
End Function
 
Public Function fMarges(Usf_Caption As String, Usf_Left As Double, Usf_Top As Double) As RECT
Dim LngResult As Long, LngHwnd As Long, DblPpx As Double, BoolFreeze As Boolean
 
    DblPpx = fPpx(72)
    If ActiveWindow.FreezePanes = True Then BoolFreeze = True: Call sLibere(False)
    LngHwnd = FindWindow(vbNullString, Usf_Caption)
    LngResult = DwmGetWindowAttribute(LngHwnd, DWMWA_EXTENDED_FRAME_BOUNDS, fMarges, LenB(fMarges))
    If fMarges.Left <> 0 Then
        fMarges.Left = Usf_Left - (fMarges.Left / DblPpx)
        fMarges.Top = Usf_Top - (fMarges.Top / DblPpx)
    End If
    If BoolFreeze Then Call sRefige(True)
End Function
 
Private Function fPpx(Nb As Long) As Double
    With CreateObject("WScript.Shell")
        fPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Nb
    End With
End Function
 
Private Sub sLibere(Comment As Boolean)
    With ActiveWindow
        Col = .SplitColumn
        Lig = .SplitRow
        .FreezePanes = Comment
    End With
End Sub
 
Private Sub sRefige(Comment As Boolean)
    With ActiveWindow
        .SplitColumn = Col
        .SplitRow = Lig
        .FreezePanes = Comment
    End With
End Sub

**Nicolas JACQUIN** · 17/07/2017, 16h31

@ pijaku
bravo, mais j'ai cette erreur avec ton nouveau ????
une idée Nom : Capture.PNG
Affichages : 262
Taille : 26,6 Ko

**pijaku** · 17/07/2017, 16h31

J'ai modifié le nombre d'arguments de la fonction.
Maintenant le ppx est calculé dans le module par une autre fonction.

Voici la procédure d'appel :

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
Private Sub CommandButton3_Click()
'pijaku
Dim R As RECT
 
    Application.ScreenUpdating = False
    R = fPosCel(ActiveCell)
    With UserForm2
        .StartUpPosition = 0
        .Show 0
        .Top = R.Top
        .Left = R.Left
        'minimum : width = 84, height = 20.25
        '.Width = R.Right
        '.Height = R.Bottom
    End With
    R = fMarges(UserForm2.Caption, UserForm2.Left, UserForm2.Top)
    With UserForm2
        .Top = UserForm2.Top + R.Top
        .Left = UserForm2.Left + R.Left
    End With
    Application.ScreenUpdating = True
End Sub

**Nicolas JACQUIN** · 17/07/2017, 16h38

merci, ton premier code était parfait aucun default
mais avec celui décalage à 100%
Nom : Capture.PNG
Affichages : 204
Taille : 2,5 Ko

**pijaku** · 17/07/2017, 16h39

J'y regarderai demain, mais logiquement je n'ai rien changé...

**Nicolas JACQUIN** · 17/07/2017, 16h40

ok merci

**Nicolas JACQUIN** · 17/07/2017, 16h46

en pleine ecran le zoom 100 est ok mais pas avec les autres
en faite c'est l'inverse

**patricktoulon** · 17/07/2017, 16h54

beau boulot pijaku

mais il faudrait pas perdre de vue qu'en utilisant DWM on exclut XP de l'équation
a méditer
aussi tester cet api avec W 10 64 et office 64

**patricktoulon** · 17/07/2017, 16h59

nicolas
4, 4, 3, 1
avec le quel?

**Nicolas JACQUIN** · 17/07/2017, 17h02

sur le fixe, je regaarderai tout a l'heure sur le portable,
parce que là le code de ce matin a été modifié et ça colle plus tu tout entre mode fenetre et mode pleine écran

**Nicolas JACQUIN** · 17/07/2017, 18h53

8, 8, 3, 1 sur le portable patrick W10 E2013 64bits

Et pour le code primaire fait par Franck ça fonctionne très bien aussi
Celui ci

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
Option Explicit
 
Private Enum DWMWINDOWATTRIBUTE
    DWMWA_NCRENDERING_ENABLED = 1
    DWMWA_NCRENDERING_POLICY
    DWMWA_TRANSITIONS_FORCEDISABLED
    DWMWA_ALLOW_NCPAINT
    DWMWA_CAPTION_BUTTON_BOUNDS
    DWMWA_NONCLIENT_RTL_LAYOUT
    DWMWA_FORCE_ICONIC_REPRESENTATION
    DWMWA_FLIP3D_POLICY
    DWMWA_EXTENDED_FRAME_BOUNDS
    DWMWA_LAST
End Enum
 
Public Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
End Type
 
Private Declare PtrSafe Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Public Function Marges(Capt$, L#, T#, ppx#) As RECT
    Dim toto As RECT, titi As Long, HwndUsf As Long ' ----->> le rectangle étendu que l'on veut extraire (aero, donc)
    HwndUsf = FindWindow(vbNullString, Capt)
    titi = DwmGetWindowAttribute(HwndUsf, DWMWA_EXTENDED_FRAME_BOUNDS, toto, LenB(toto))
    Marges.Left = L - (toto.Left / ppx)
    Marges.Top = T - (toto.Top / ppx)
End Function
Private Sub CommandButton1_Click()
Dim L#, T#, R As RECT, ppx#
 
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With UserForm2
        .StartUpPosition = 0
        .Show 0
        .Top = (ActiveWindow.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) / ppx)
        .Left = (ActiveWindow.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) / ppx) ' - 5
    End With
    R = Marges(UserForm2.Caption, UserForm2.Left, UserForm2.Top, ppx)
    L = R.Left
    T = R.Top
    With UserForm2
        .Top = UserForm2.Top + T
        .Left = UserForm2.Left + L
    End With
End Sub

Le dernier par contre déconne selon pleine écran ou mode fenêtre, sur n'importe quel pc

**patricktoulon** · 17/07/2017, 19h11

perso j'avais plantage ou disparition de l'usf je ne sais ou en theme window classic

j'ai repris sa premiere version et a jouter la condition 0 son dernier code plantait

Code :

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

1
2
3
4
5
6
7
Public Function Marges(Lcaption$, L#, T#, ppx#) As RECT
    Dim rectangle As RECT, handleusf As Long    ' ----->> le rectangle étendu que l'on veut extraire (aero, donc)
    handleusf = FindWindow(vbNullString, Lcaption)
    DwmGetWindowAttribute handleusf, DWMWA_EXTENDED_FRAME_BOUNDS, rectangle, LenB(rectangle)
    Marges.Left = IIf(rectangle.Left / ppx <> 0, L - (rectangle.Left / ppx), 0)
    Marges.Top = IIf(rectangle.Top / ppx <> 0, T - (rectangle.Top / ppx), 0)
End Function

**unparia** · 17/07/2017, 19h16

mais il faudrait pas perdre de vue qu'en utilisant DWM on exclut XP de l'équation

Ah !
Et à quoi sert la compilation conditionnelle ? à jouer à la marelle ?
Relire mon message n° 881.
J'attends que tout soit définitivement arrêté pour montrer comment. Ce ne sera pas compliqué du tout

**patricktoulon** · 17/07/2017, 19h21

donc en gros pour W7 et W10
si theme aero (W7)9,9,3,1
ou theme "Roamed"(W10 équivalent thème aero) 8,8,3,1

si thème autre(w7) et autre(w10) 4,4,3,1

on est d'accord?

**patricktoulon** · 17/07/2017, 19h26

Envoyé par unparia

Ah !
Et à quoi sert la compilation conditionnelle ? à jouer à la marelle ?
Relire mon message n° 881.
J'attends que tout soit définitivement arrêté pour montrer comment. Ce ne sera pas compliqué du tout

je sais pas j'ai pas regardé mais perso je mettrais une condition renvoyant le long de l'opération avec l'api si 0 rien sinon faire
tu parle de userform plat selon tes captures j'en conclu que tu n'utilise pas le thème XP mais le window classic ou le oldwindow si je me souviens bien
donc avec le thème XP A TU UN DECALAGE?

**unparia** · 17/07/2017, 19h33

donc avec le thème XP A TU UN DECALAGE?

Bien évidemment que non, puisqu'alors il n'y a pas de rectangle étendu recouvrant le userform

je sais pas j'ai pas regardé

Besoin de regarder quoi ? tu ne sais pas que la compilation conditionnelle existe ? (curieux, mais tu l'utilises dans certains de tes codes ... sans savoir ce que c'est ?)

mais perso je mettrais une condition renvoyant le long de l'opération avec l'api si 0 rien sinon faire

Là, ce serait pour le cas où présence mais non activation de aero.
Ben non. Je pense être en mesure (bien que sous XP et sans aero, moi

) de le savoir directement (toujours avec la même librairie -mais une autre de ses fonctions - que celle que j'ai utilisée. Ce sera ainsi bien plus "propre" et surtout : dans l'esprit de Windows

).

Positionner curseur sur une cellule sélectée Windows Excel VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager