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

Version imprimable

Voir 40 message(s) de cette discussion en une page

17/07/2017, 15h01
Invité

J'obtiens 8,8,3,1 avec ton test Patrick.
17/07/2017, 15h02
pijaku

Avec aero : 8, 8, 3, 1
Sans aero : 4, 4, 3, 1
17/07/2017, 15h12
patricktoulon

re

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
17/07/2017, 16h03
Nicolas JACQUIN

4, 4, 3, 1

Attention également à Application.ScreenUpdating...

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

Code:

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

17/07/2017, 16h31
Nicolas JACQUIN

1 pièce(s) jointe(s)

@ pijaku
bravo, mais j'ai cette erreur avec ton nouveau ????
une idéePièce jointe 294746

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:

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

17/07/2017, 16h38
Nicolas JACQUIN

1 pièce(s) jointe(s)

merci, ton premier code était parfait aucun default
mais avec celui décalage à 100%
Pièce jointe 294747
17/07/2017, 16h39
pijaku

J'y regarderai demain, mais logiquement je n'ai rien changé...
17/07/2017, 16h40
Nicolas JACQUIN

ok merci
17/07/2017, 16h46
Nicolas JACQUIN

en pleine ecran le zoom 100 est ok mais pas avec les autres
en faite c'est l'inverse
17/07/2017, 16h54
patricktoulon

re

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
17/07/2017, 16h59
patricktoulon

re

nicolas
4, 4, 3, 1
avec le quel?
17/07/2017, 17h02
Nicolas JACQUIN

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

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:

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

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:

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

17/07/2017, 19h16
unparia

Citation:

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 :lol:
17/07/2017, 19h21
patricktoulon

re

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?
17/07/2017, 19h26
patricktoulon

Citation:

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 :lol:

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?
17/07/2017, 19h33
unparia

Citation:

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

Citation:

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 ?)

Citation:

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 :D) 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 ;)).

Voir 40 message(s) de cette discussion en une page