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

Version imprimable

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

20/07/2017, 14h19
patricktoulon

:ptdr:

oupss!! "connes/colonnes" non il faut tes deux colonnes identiques pour le test

ne pas oublier aussi que chez moi je suis en 120 dpi

1pixel *125%=1.25( 1.25 pixel étant impossible ca donne toujours 1)

atu une dim identique avec ca

Code:

1
2
3
4
5
6
7
Sub testpijaku2()
 With ActiveWindow
 w1 = (.ActivePane.PointsToScreenPixelsX([A1:F1].Width) - .ActivePane.PointsToScreenPixelsX(0)) / (.Zoom / 100)
w2 = (.ActivePane.PointsToScreenPixelsX([g1].Left) - .ActivePane.PointsToScreenPixelsX(0)) / (.Zoom / 100)
End With
MsgBox w1 & vbCrLf & w2
End Sub

20/07/2017, 14h45
pijaku

Je ne comprends pas pourquoi tu t'obstines à me faire tester des cellules au hasard.

Je t'ai dit que, dans la plupart des cas, PointToScreenPixels(X/Y) renvoie les bonnes coordonnées, mais, dans certains cas, sur certaines cellules, ces coordonnées sont fausses.

Il est inutile de tester les cellules ou tout se passe bien!

Quand aux cellules ou la méthode ne fonctionne pas, on ne pourra rien y changer.

Si tu recherches la perfection absolue dans tous les cas de figure, il faut se passer de PointToScreenPixels.

Bon courage!

EDIT : pour ma part :
> les fonctions développées ici fonctionnent dans la plupart des cas
> lors d'erreurs elles sont quasi insignifiantes
Par conséquent, je considère qu'un avertissement à l'utilisateur suffit.
D'autant que l'échec ne nous est pas imputable.
20/07/2017, 14h52
patricktoulon

re

chez moi l'erreur de "1" est sur toutes les cellules (n'importe la quelle)

avec pointstoscreenpixelsx(une seule cellule.width)

pour être précis elle sur n'importe quel point de l'écran avec pointstoscreenpixelsx(une cellule.leftt)
20/07/2017, 15h17
pijaku

Je crois, Patrick, que tu n'as pas modifié la hauteur des lignes ni la largeur de tes colonnes pour faire tes tests.

Essaye, tu comprendras mieux.

1 pièce(s) jointe(s)

j'étais vraiment curieux avec W10
j'ai donc installé W10 2010 sur mon portable

et on a vraiment a boire et a manger la dedans

voila ce qu'il me faut pour avoir un résultat parfait sur toutes les celles je dis bien sur toutes les cellules en dpi 96 et a tout les zooms

je n'ai aucune différence sur n'importe quelle colonne
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub test() With CreateObject("WScript.Shell") ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 ' Application.InchesToPoints(1) End With MsgBox ppx With ActiveWindow x = (.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) / ppx) - 2 y = (.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) / ppx) - 1 End With With UserForm1 .Show 0 .Left = x .Top = y End With End Sub
Pièce jointe 295718

je reviens je vais éssayer en dpi 120

et voila pour dpi120 et meme resultat sauf que la surprise surprise j'ai le defaut sequentiel des colonnes
le responsable est donc bien le dpi modifié
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub test() With CreateObject("WScript.Shell") ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 ' Application.InchesToPoints(1) End With MsgBox ppx With ActiveWindow x = (.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) / ppx) - 2 y = (.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) / ppx) - 3 End With With UserForm1 .Show 0 .Left = x .Top = y End With End Sub
après si je prends la calculette
que je fait 1.333333333333333*1.25 (125%par dpi120)
j'obtiens pas le ppx que l'on a l'habitude d'utiliser en dpi 120

1,666666666666666

donc quand je remplace ppx par ce nombre j'obtiens le même résultat que dpi 96 seulement sur les cellules qui ne donne pas une fausse donnée en terme de left et top

des que je rentre du bureau j'essai sur le fixe avec Windows 7

20/07/2017, 19h24
unparia

J'aimerais vraiment (et c'est important pour y voir clair) que l'on série les problèmes.
Nous avons déjà (le dernier test que j'ai proposé plus haut) traité le cas de l'application SEULE de DMW et constaté qu'elle était sans faille.
Il convient maintenant de traiter celui de la SEULE application] (sans rien d'autre) de la méthode PointstoScreenPixelsX/Y
Le moyen de le faire est exposé dans mon message (âgé de plus de 20 jours) N° 329
Le test qui y est proposé est simple et sa finalité est de placer le seul curseur et d'examiner si sa position est correcte ou non dans tous les cas, notamment avec aero, avec et sans zoom etc ...

Ne pas oublier d'ajouter dans la partie déclarative :

Code:

Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

C'est en éliminant ainsi le placement de l'userform et en n'examinant que le seul résultat de ce code, que l'on saura de manière indubitable si la méthode PointstoScreenPixelsX/Y connaît ou non une faille.
C'est Cela, que j'appelle "sérier". Et cela permet d'éviter de s'interroger sur la responsabilité éventuelle de tel ou tel élément lorsque plusieurs éléments entrent en jeu en même temps. Ce n'est qu'en mettant en jeu UN SEUL élément à la fois que l'on peut déterminer s'il est, LUI, fautif ou non.

EDIT : Le test que je proposais en mon message 329 est tel qu'il permet une meilleure estimation visuelle (curseur en forme de flèche dont la pointe montre mieux le placement que ne le fait la forme du curseur lorsqu'il est sur une cellule)

Je pensais cette histoire avec la méthode PointstoScreenPixelsX/Y résolue!

La méthode PointstoScreenPixelsX/Y déconne, n'en déplaise à Patrick.

Ton test Jacques, je l'avais réalisé et... ça déconnait.

Pourquoi cela déconne chez certains et pas chez d'autres ?
Vous voulez l'explication ?
Je vous ai donné un indice, aujourd'hui à 15h17...

En fait, dans la grille d'excel, telle qu'elle est construite "à la base" (nouvelle feuille), la méthode PointstoScreenPixelsX/Y ne se trompe jamais!
C'est à penser que les gens de Microsoft l'on créée exprès avec ces caractéristiques la, juste pour faire fonctionner la méthode PointstoScreenPixelsX/Y...

Par contre, dès que l'on fait varier la hauteur d'une ligne ou la largeur d'une colonne, à un moment donné, ça plante.
N'essayez pas de faire des tests "manuellement", vous risquez fort de tomber systématiquement sur une taille qui "fonctionne".

Par contre, testez via une macro en faisant un "truc" du style :
Code:

1 2 3 4 5 6 7 8 9 'écrit sur le forum donc pas forcément fiable Sub testHauteurLigne() Dim i& For i = 1 to 100 Rows(5).RowHeight = Rows(5).RowHeight + 0.5 'test de la méthode PointstoScreenPixelsX/Y sur A5 et A6 'imaginez le test que vous voulez, ça déconnera à un moment... Next i End Sub
Code:

1 2 3 4 5 6 7 8 9 'écrit sur le forum donc pas forcément fiable Sub testLargeurColonne() Dim i& For i = 1 to 100 Columns(5).ColumnWidth = Columns(5).ColumnWidth + 1 'test de la méthode PointstoScreenPixelsX sur E2 et F2 'imaginez le test que vous voulez, ça déconnera à un moment... Next i End Sub
Et c'est uniquement cette absence de test de Patrick qui fait que l'on ne sait toujours pas si la méthode PointstoScreenPixelsX/Y déconne ou pas.

Stp, Patrick, essaye.... Teste en variant les hauteurs de lignes et de colonnes...

A propos de test, Jacques, est ce que ce test te paraitrait concluant?
Code:

1 2 3 4 5 6 With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With With ActiveWindow wactivecell = (.ActivePane.PointsToScreenPixelsX(ActiveCell.Width) - .ActivePane.PointsToScreenPixelsX(0)) / (.Zoom / 100) w2 = (ActiveCell.Width * ppx) If wactievcell <> w2 Then MsgBox "la méthode PointstoScreenPixelsX/Y déconne" End With
ou pas...
C'est Patrick qui le proposait cette après midi.

Bonne réflexion à toutes et tous!

EDIT : Jacques, lorsque tu parles de sérier, dans mes fonctions, si tu avais pu tester, tu aurais bien vu que je séparais (depuis le début) l'utilisation de la méthode PointstoScreenPixelsX/Y de celle de dmw.
Du coup, ce qui déconnais était évident...

EDIT2 : pour être tout à fait clair...
MES TESTS tendent à prouver que la méthode PointstoScreenPixelsX/Y ne déconne en aucun cas sur une "grille excel neuve". Quel que soient le zoom, le dpi ou autre.
Mais, je le reconnais, ce ne sont que MES tests et ceux-ci peuvent (au vu de mon manque de connaissances) être défaillants...

1 pièce(s) jointe(s)

depuis un moment tout le monde a compris que pour capter le décalage entre autre il fallait les api (dwm,ect)

@jacques le seul résultat que tu a eu de "ajust" c'est celui de pijaku , ca me parait sans vouloir offenser personne de prendre ce résultat pour exact a 100% surtout que le disant lui même (avec démo en plus) la fonction pointstoscreenpixel a l'air de dérailler chez lui

pour ma part
je constate que :
en 96 dpi et sans aero !!! rien!!! queudale!!! visuellement c'est parfait je n'ajoute rien ,je n'enlève rien , attention je dis bien visuellement car en vérité il n'en est rien mathématiquement parlant mais les nuances sont si petites que vba arrondi

aero et theme W10
on constate un décalage sur W7 identique pour le top et left
pour Windows 10 c'est la débandade on a aucun repère aucun n'a le même décalage avec le thème W10 original

dpi 96 / 120
alors la on constate un ecart sur certaines colonnes (qui en plus!!varie en pourcentage) selon le zoom

j'était curieux de trouver le moyen de tester la différence visuellement et mathématiquement sans userform et sans api
tu me diras c'est facile pointstoscreenpixel ramené en points et c'est bon oui sauf que le résultat est bon mathématiquement (dommage)

alors pour en avoir le cœur net j'utilise non pas les api, non pas un userform

juste une shape !!!

pourquoi?

parce que la on a tout les outils de:
sheets(x).shapes
c'eux de l application
c'eux de l'activewindow
bref tout ce que l'on peut pas faire avec un userform sans api

j'ai simplement fait une petite sub
qui place le shape avec pointstoscreenpixel
dans le quel j'incrit le topleftcell(ici déjà on a la réponse a ta question )

j'inscrit les données left par ptoscpix et celle de left cellule
je fait meme la soustraction

et c'est la que l'on vois vraiment que AUCUNE CELLULE NE CORRESPONT A P....TOSC....PIXTLS

ALORS TON PREMIER REFLEXE SERA DE ME DIRE TU TE CONTREDI alors !!!!!!

MOI JE DIS NON!!

car une chose est sur: a pointstoscreenpixels est injecté quoi!!!!!????? ACTIVECELl.TOP OU LEFT !!!!!!!!!

bref pour ne pas trop romancer et aller a l'essentiel de mon point de vue tu en fera ce que tu voudras

voici ce petit code je me suis contenter de faire que pour le left pour le top faire pareil

Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 [Sub testshape() With ActiveWindow With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With x = ((1 + .ActivePane.PointsToScreenPixelsX(ActiveCell.Left) - .ActivePane.PointsToScreenPixelsX(0)) / ppx) / (.Zoom / 100) y = ((.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100) Set shap = ActiveSheet.Shapes.AddShape(1, x, y, 70, 120) texte = "topleftcell " & shap.TopLeftCell.Address & vbCrLf texte = texte & "ActiveCell.Left " & ActiveCell.Left & vbCrLf texte = texte & " pttoscreenpixX " & x texte = texte & " diff left " & x - ActiveCell.Left shap.TextFrame.Characters.Text = texte shap.TextFrame.Characters.Font.Size = 6 shap.Line.Weight = 3 End With End Sub

voila dans le shape tu devrait avoir leur différence individuelles

fait le test sur toute les cellule d'une même ligne et regarde bien les ecarts
tu peut faire aussi le test sur des cellules eloignées en terme de colonnes et de lignes et (bien regarder la bordure

voila

apres faut pas déconner on a bien bossé quand même
mais peut etre que si tu t'interesse ames shapes tu va nous trouver la solution sans api hein !!??? je dis ca je dis rien moi ;)
et pour ilustrer ce que je dis

dpi 120 thème aero désactivé
et la déjà en regardant simplement les bordures verticales on a compris

Pièce jointe 295873

Ne mélange pas les genres, Patrick

Citation:

déjà en regardant simplement les bordures verticales on a compris

1) Une Shape n'est pas un userform (dont la hauteur comprend les bordures)
2) les bordures d'une Shape viennent s'ajouter autour de la Shape. Elle n'en font pas partie et ne modifient en aucun cas les dimensions de la Shape elle-même
Il suffit de peindre la shape en rouge pour voir que tu as d'une part la shape et d'autre part ses bordures
Or, tu as mis des bordures (de 3, en plus)
3) tu aurais le même effet et les mêmes "occupations" en donnant directement x et y les coordonnées de la cellule (sans PointstoscreenpixelsX/Y)
Preuve de tout cela
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 With ActiveWindow With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With '<s>x = ((1 + .ActivePane.PointsToScreenPixelsX(ActiveCell.Left) - .ActivePane.PointsToScreenPixelsX(0)) / ppx) / (.Zoom / 100)</s> x = ActiveCell.Left ' <s> y = ((.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100)</s> y = ActiveCell.Top Set shap = ActiveSheet.Shapes.AddShape(1, x, y, 70, 120) texte = "topleftcell " & shap.TopLeftCell.Address & vbCrLf texte = texte & "ActiveCell.Left " & ActiveCell.Left & vbCrLf texte = texte & " pttoscreenpixX " & x texte = texte & " diff left " & x - ActiveCell.Left shap.TextFrame.Characters.Text = texte shap.TextFrame.Characters.Font.Size = 8 shap.Line.Weight = 3 shap.Fill.ForeColor.RGB = RGB(255, 0, 0) End With
Quant aux coordonnées retournées par PointstoscreenpixelsX/Y, elle le sont par rapport à l'écran. Celles des shapes le sont par rapport à ActiveWindow.

Lu dans l'aide pour let, par exemple :

Citation:

Left : Cette propriété renvoie ou définit une valeur de type Single qui représente la distance en points entre le bord gauche de l'objet et le bord gauche de colonne A (d'une feuille de calcul) ou le bord gauche de la zone de graphique (dans un graphique).

Je vais quant à moi t'apporter la preuve contraire -->> pourquoi passer par une shape, avec les risques induits de "pollution" dus à la shape, ses bordures et son placement ?-->> pas la peine --->>
Code:

1 2 3 4 5 With ActiveWindow With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With y = ((.ActivePane.PointsToScreenPixelsY(Range("B4").Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100) MsgBox Range("B1:B3").Height & " " & y End With

Bonjour,

Pourriez-vous relire mon message 1008 d'hier soir?

Je viens de tester (à nouveau) avec ces codes :

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
83
84
85
Option Explicit
 
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 
Sub Test_PointsToScreenPixelsZOOM()
Dim i&, cible As Range
 
For i = 50 To 400 Step 20
    ActiveWindow.Zoom = i
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
End Sub
 
Sub Test_PointsToScreenPixelsHAUTEUR()
Dim i&, cible As Range, HauteurInitiale As Single
HauteurInitiale = Rows(3).RowHeight
    ActiveWindow.Zoom = 300
For i = 1 To 100
    Rows(3).RowHeight = Rows(3).RowHeight + 0.5
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
Rows(3).RowHeight = HauteurInitiale
    ActiveWindow.Zoom = 100
End Sub
 
Sub Test_PointsToScreenPixelsLARGEUR()
Dim i&, cible As Range, LargeurInitiale As Single
 
LargeurInitiale = Columns(1).ColumnWidth
    ActiveWindow.Zoom = 300
For i = 1 To 100
    Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
Columns(1).ColumnWidth = LargeurInitiale
    ActiveWindow.Zoom = 100
End Sub

Conclusion :

Le zoom ne change en rien la position du curseur
La hauteur de ligne fait que le curseur n'est pas bien positionné par moment (ce n'est pas systématique)
Idem pour la largeur de colonne

Peut-on en conclure que la méthode .PointsToScreenPixels ne fonctionne pas correctement?

Je reviens...

Mêmes conclusions en 96 et 120 DPI (Normal!)

EDIT : de retour!
Par contre, sur une feuille neuve, aucun souci avec PointsToScreenPixels...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Test_PointsToScreenPixelsSurFeuilleNeuve()
Dim C, cible As Range, LargeurInitiale As Single
 
For Each C In ActiveWindow.VisibleRange
    Set cible = C
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
    .Text = ActiveWindow.Zoom & "  Left : " & ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left) & "  " & " Top : " & ActiveWindow.ActivePane.PointsToScreenPixelsY(cible.Top)
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
End Sub

EDIT2 : essayez cette macro plusieurs fois d'affilé (il s'agit du test de Jacques de cette nuit)...

Code:

1
2
3
4
5
6
7
8
Sub unparia1010()
    With ActiveWindow
        Rows(2).RowHeight = Rows(2).RowHeight + 0.25
        With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
        y = ((.ActivePane.PointsToScreenPixelsY(Range("B4").Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100)
        MsgBox Range("B1:B3").Height = y
    End With
End Sub

21/07/2017, 08h46
unparia

Bonjour Franck

Dès mon retour de la pêche, je mettrai ici une démonstration très nette (faite ce matin) d'une faille de la méthode pointstoscreenpixels ;)

2 pièce(s) jointe(s)

ok j'attend ta demo

mais pour ma démo c'est voulu la bordure c'était pour démontrer la même chose que pour l'userform et le topleftcell parle pour moi
quand tu fait userform1.left =x

vba compte x sans le rajout d'un éventuel thème

ensuite pointstoscreenpixel a une faille ?
je sais pas trop tu va certainement nous le montrer perso je vois pas

en terme mathematique calcul pure je peux te dire oui mais en terme d utilisation je te dis non

depuis un moment déjà comme je te l'ai dis pointstoscreenpixel est adapté a la deformation de l'effet zoom par le zoom excel ou par le dpi en l'occurrence le 120 qui grossi les surface mais change les proprortions

pour te donner vraiment un aperçu réel de mon point de vue
voici deux macro toutes simples

dans la premiere il est nullement question de conversion que ce soit simplement activecell pour placer la cellule

l'autre utilise ma formule que tu déteste tant et j'ai mis en commentaire la ligne ppx par le registre

j'utilise 2 cellules d'une même colonne et place une shape identique avec les deux macro

demo avec ppx par ppx du registre selon le dpi au dessus et coeeficient ppx par pointtoscreenpixel en dessous le résultat s'inscrit dans le shape il est plus que parlant
la shape du dessous est posé avec simplement activecell sans calcul
Pièce jointe 295911Pièce jointe 295914
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 Sub testshape() With ActiveWindow Z = (.Zoom / 100) ' With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With ppx = (.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) - .ActivePane.PointsToScreenPixelsX(0)) / (ActiveCell.Left * Z) x = ((.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) - .ActivePane.PointsToScreenPixelsX(0)) / ppx) / (.Zoom / 100) 'x = ((.ActivePane.PointsToScreenPixelsX(Range(Cells(1, 1), ActiveCell.Offset(0, -1)).Width) - .ActivePane.PointsToScreenPixelsX(0)) / ppx) / Z y = ((.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100) Set shap = ActiveSheet.Shapes.AddShape(1, x, y, 70, 120) texte = "topleftcell " & shap.TopLeftCell.Address & vbCrLf texte = texte & "ActiveCell.Left " & ActiveCell.Left & vbCrLf texte = texte & " pttoscreenpixX " & x texte = texte & " diff left " & x - ActiveCell.Left shap.TextFrame.Characters.Text = texte shap.TextFrame.Characters.Font.Size = 6 shap.Line.Weight = 3 End With End Sub Sub testuneshape() Set shap = ActiveSheet.Shapes.AddShape(1, ActiveCell.Left, ActiveCell.Top, 70, 120) shap.TextFrame.Characters.Text = texte shap.TextFrame.Characters.Font.Size = 6 shap.Line.Weight = 3 MsgBox ActiveCell.Left End Sub
tu n'a qu'a faire le teste toi même tu verra simplement en bloquant la ligne ppx (l'une ou l'autre)

si je puis m'exprimer ainsi en fait toute les données de l'Operations sont fausses quand on utilise une valeur externe a excel en ce qui concerne l'affichage

ppx registre ou api faux
zoom faux car l'affichage est déformé et ne correspond pas proportionnellement a ce qui est affiché en mode aero d'abord puis en dpi 120 c'est pire
en gros pour faire simple
quand tu vois ta fenêtre Excel dans ton écran tu vois une représentation approximative de ce qui est
tout est modifié avec le theme ou le dpi ( je dis bien tout)
la preuve c'est qu'en désactivant tout c'est nikel avec les même calcul avec pointstoscreenpixels que aime tant ;)

et pour la différence avec W10 qui lui donne plus loin toujours !!

vous avec qu'a vous demander pourquoi sur cette version de Window ils ont laissé DWM qui dans cette version de modifie que l'intérieur de la caption et cadre ,vous aurez votre réponse

je te le démontre quand tu veux ;)

21/07/2017, 12h17
unparia

Citation:

ensuite pointstoscreenpixel a une faille ?
je sais pas trop tu va certainement nous le montrer perso je vois pas

en terme mathematique calcul pure je peux te dire oui mais en terme d utilisation je te dis non

Et comment qu'il a une faille! Et tu la verras, mathématiquement ET visuellement. Y compris sans zoom, sans aero et sous XP. Juste en plaçant le curseur par setcursorpos aux coordonnées calculées par PointsToScreenPixelsX/Y
Je dois sortir, puis me reposer. Il me faut agrémenter la demo de messages. J'essaierai également de donner mon explication de la faille sporadique (dépend des dimensions données aux cellules).
J'essaierai ensuite (plus tard) de contrecarrer cette faille, mais ne sais pas si j'y parviendrai (si ce que je pense est vrai, ce sera assez difficile, voire impossible depuis l'extérieur du code que gère PointsToScreenPixelsX/Y)

Bonjour,

ça me semble compliqué.
D'autant que SetCursorPos travaille avec des entiers et non des décimaux.

Par exemple :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Sub test()
Dim pos As POINTAPI, ppx as double
   ppx = 4/3 'ou 5/3 pour DPI 120
   pos.X = 0
With ActiveWindow.ActivePane
   pos.Y = (.PointsToScreenPixelsY(5) - .PointsToScreenPixelsY(0)) / ppx
End With
'ICI pos.Y = 5, mais (.PointsToScreenPixelsY(5) - .PointsToScreenPixelsY(0)) / ppx = 5,25
   SetCursorPos pos.X, pos.Y '=> positionnement du curseur aux coordonnées X = 0, Y = 5
End Sub

Enfin, je ne souhaite pas aller trop vite et j'attends ton retour.

Bon.
Le voilà, le test en question .
Il met très clairement en exergue la carence de PointsToScreenPixels confronté à certaines dimensions de cellules
Dans ce test (où tout est pourtant simple ... ni aero, ni zoom) : se plantera (décalage) avec la cellule D11. Et très curieusement : sera de nouveau précis avec la cellule D14 !
Pour tester :
- une feuille avec un bouton de commande commandbutton1 et un label Label1
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 Private Sub CommandButton1_Click() Range("A1:A20").RowHeight = 15 '| voilà un exemple de cellules posant problème Range("A10").RowHeight = 64.5 Columns(2).ColumnWidth = 10 DoEvents With CreateObject("WScript.Shell") ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 End With With ActiveWindow y = ((.ActivePane.PointsToScreenPixelsY(Range("D14").Top) - .ActivePane.PointsToScreenPixelsY(0)) / ppx) / (.Zoom / 100) MsgBox Range("D1:D13").Height & vbCrLf & y & vbCrLf & "écart : " & Range("D1:D13").Height - y & vbCrLf & _ "pointstoscreenpixelsX s'est planté dans cette configuration de hauteurs de cellules !" & vbCrLf & _ "Faisons maintenant le test de mon message 329 d'il y a 20 jours" & vbCrLf & vbCrLf & _ "Nous allons demander que le curseur se place en cellule D11 (et nous observerons un décalage)" & vbCrLf & _ "puis en cellule D14 (et étrangement : plus de décalage !) " BlockInput True Set cible = Range("D11") DoEvents With Label1 .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) .Width = 400 End With With ActiveWindow.ActivePane SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top) ' REGARDER LE DECALAGE ! End With Application.Wait Now + TimeValue("0:00:05") ' attente pour donner le temps de voir Set cible = Range("D14") With Label1 .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) End With With ActiveWindow.ActivePane SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top) End With BlockInput False ' --->> je réhabilité souris et clavier End With End Sub
Et (à l'attention de Patrick) : ce code ne fait appel qu'à la méthode PointstoScreenPixels (SACREMENT MISE EN CAUSE) et à la fonction SetCursorPos (qui ne saurait être mise en cause). :lol:

Ce que je "devine" : PointstoScreenPixels est en défaut lorsque l'une (ou les deux) des deux coordonnées de la cellule cible (en points au départ), une fois convertie(s) en pixels, ne sont pas un nombre entier de pixels. Il semble qu'ait été passé aux oubliettes un calcul d'ajustement rendu alors nécessaire (du genre de celui que j'ai montré dans un message précédent pour le placement de userforms).

Ce ne sera que ce soir que je me mettrai à tenter de corriger depuis l'extérieur (pas facile et sans aucune certitude de résussite).

Alors, Patrick ? Coupable ou pas coupable, la méthode PointsToScreenPixels . :D
Elle est seule à être ici utilisée ...:coucou:

21/07/2017, 15h20
pijaku

Je confirme.

Attention toutefois à :

Code:

BlockInput

N'existe pas.
J'ai juste commenté les 2 lignes.
21/07/2017, 15h37
unparia
Salut Franck
J'ai juste oublié de tout copier/coller :D

Dans la partie déclarative :
Code:

1 2 3 Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
J'ai ajouté la fonction BlockInput pour éviter les conséquences de tout mouvement mal contrôlé de la main sur la souris . Le test est plus sûr ainsi.

Par ailleurs : les essais que je suis en train de faire pour "corriger depuis l'extérieur" m'effraient. Si mon essai de correction (efficace) est toujours vrai, le code de la méthode PointsToScreenPixels est alors vraiment honteux, voire carrément scandaleux !
Je reviendrai en parler plus tard.

EDIT : j'avance avec encore plus de certitude et c'est encore pire : conjugaison de deux facteurs : l'un dû à un aspect caché de Excel, l'autre à une ignorance de cet aspect par la méthode PointsToScreenPixels. C'est un comble et un "kilombo" (salut au passage au Porteño s'il passe par là ;)) total !
21/07/2017, 17h24
patricktoulon

Re

Je regarde ca en rentrant mais le peu que j ai vu sur le smart phone me mpntre que vous avez pas compris ce que j ai dis plus haut
Il faut banir votre ppx il est pas bon!!!!!!
Mais je regarderais plus en detail ton travail toute a l heure quans je rentre
21/07/2017, 18h32
patricktoulon

1 pièce(s) jointe(s)

RE

re
bon me voila de retour

jacques j'ai testé ton code
j'ai simplement mis en commentaire blockinput et ajouter" activesheet." devant label1

j'ai une question;)
qu'a tu voulu me démontrer????????? la il faut m'expliquer

chez moi c'est nikel
je ne peut rien te dire de plus je vais examiner le code que tu a produit mais je vois pas ce que je peut faire
et pourtant je suis dans les plus mauvaise conditions (aero et dpi 120)
j'ai testé sur un fichier vierge

démo en image
Pièce jointe 296234

je t'en prie fait quelque chose avec ton XP ;)
21/07/2017, 18h48
pijaku
Rien à voir avec XP car j'ai eu le même problème.
En fait, l'écart qui cause le problème est différent selon les configurations.
Va faire les tests de mon message de ce matin.

Jacques :
N'y a t'il pas également un souci avec la propiété Height des cellules? (et donc de leur Top par analogie, etc...)
Code:

1 2 3 4 5 6 7 Sub Testheight() Dim i& For i = 1 To 5 Rows(2).RowHeight = Rows(2).RowHeight + 0.25 Debug.Print Range("B1:B4").Height Next End Sub
21/07/2017, 18h53
patricktoulon

1 pièce(s) jointe(s)

re

bonjour franck
oui certainement une difference de config

mais bon chez moi c'est top
démo sans aero pareil en 120dpi

Pièce jointe 296244
21/07/2017, 19h14
pijaku

Patrick, stp fait les tets que je propose au post 1011...
T'en as pour 5 minutes.

Citation:

N'y a t'il pas également un souci avec la propiété Height des cellules? (et donc de leur Top par analogie, etc...)

C'est d'ailleurs ce sur quoi je travaille depuis près d'une heure. On dirait bien que Excel modifie les dimensions des cellules au 1/4 de point le plus proche.
Je ne suis cependant pas totalement certain de ce qu'il faille calculer sur cette base-là car le top d'une cellule est la somme des height des cellules au-dessus. Or le total arrondi de valeurs n'est pas égal à la somme des arrondis de ces valeurs.
Je serais donc étonné de ce que PointstoScreenPixels fasse ce genre d'arrondis. On dirait par contre fort que cette zazou de méthode se base sur l'entier de la valeur et non sur un arrondi, qu'il soit l'entier le plus proche ou qu'il soit le multiple le plus proche de quarts de points ! (lire et relire lentement cette phrase)
J'ai d'ailleurs essayé sur cette base (celle d'un ajustement par rapport à l'entier pur et simple de la valeur)
Tout semble bon ainsi, mais je continue des tests (pour écarter autant que faire se peut les coïncidences heureuses)
On ne saurait être assez nombreux à faire de tels tests, en modifiant des hauteurs et largeurs de cellules . Plus leur nombre sera élevé, mieux cela vaudra.
Voici donc ce qui parait marcher à tous les coups :
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 Private Sub CommandButton1_Click() Range("A1:A20").RowHeight = 16 '| voilà un exemple de cellules posant problème Range("A10").RowHeight = 64.5 Columns(2).ColumnWidth = 10 DoEvents With CreateObject("WScript.Shell") ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 End With With ActiveWindow BlockInput True Set cible = Range("D11") DoEvents With Label1 .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) .Width = 400 End With With ActiveWindow.ActivePane titiy = Int(cible.Top) titix = Int(cible.Left) SetCursorPos .PointsToScreenPixelsX(titix), .PointsToScreenPixelsY(titiy) End With Application.Wait Now + TimeValue("0:00:05") ' attente pour donner le temps de voir Set cible = Range("D14") With Label1 .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) End With With ActiveWindow.ActivePane titiy = Int(cible.Top) titix = Int(cible.Left) SetCursorPos .PointsToScreenPixelsX(titix), .PointsToScreenPixelsY(titiy) End With BlockInput False ' --->> je réhabilité souris et clavier End With End Sub
Voilà où j'en suis pour l'instant.

21/07/2017, 19h32
patricktoulon

re

oUi sauf que tu a oublié de mettre les scroll a 1 a chaque tour sinon a un moment on le voit plus c'est normal
je l'avais déjà fait ce test y a au moins 300 posts et tu dois même retrouver la démo animée

mais bon je vais tester si veux
21/07/2017, 19h38
unparia

Citation:

je l'avais déjà fait ce test y a au moins 300 posts et tu dois même retrouver la démo animée

Quel N° de message, s'il te plait ?
(je n'ai pas souvenir de tests que tu aurais faits et montrés en se limitant au seul setcursorpos obtenu par la seule méthode PointsToScreenPixels. Car tout test qui montrerait le placement du userform et non le seul curseur serait entâché de vices autres éventuels).
21/07/2017, 19h45
patricktoulon

1 pièce(s) jointe(s)

re

franck voila ta demo
Pièce jointe 296249

vous faite fausse route en interpretant "l'erreur" de pointstoscreenpioxels justement comme une erreur

je l'ai dis 100 fois

pointstoscreenpixels te donne ce qu'il y a vraiment affiché a l'écran en ce qui concerne tout l'active window

le userform lui il lui faut quoi ???????????!!!!!!!!!!!!!!!

il lui faut les vrai pixels de l'écran car il n'est pas membre de l'activewindow et donc pas déformé

ajoutez a cela le dpi déformant encore plus en 120

ajoutez a ca les thèmes des diverses versions de window dont la plus spectaculaire connerie est c'elle de W10

dites moi pourquoi on a gardé DWM dans window10 hein dites moi puisque les caption et cadre ne peut entre changés seulement de font ,couleur et 2 ou trois autre conneries mais en aucun cas un redimensionnement de la caption et cadre comme dans W7

et si vous ajoutez la différence de W7 aero en moins dans W10 puré miracle ca match a ben ca alors

bravo Microsoft

allez vous m'écouter enfin !!!
21/07/2017, 19h52
unparia

Citation:

le userform lui il lui faut quoi ???????????!!!!!!!!!!!!!!!

il lui faut les vrai pixels de l'écran car il n'est pas membre de l'activewindow et donc pas déformé

Cela a DEJA été traité (Franck fignolle même cette partie-là). Aucun problème lorsque les coordonnées retournées par la méthode PointsToScreenPixels sont exactes.

C'est cela, l'avantage de sérier les problèmes.
Le seul suspect résiduel est la méthode PointsToScreenPixels
21/07/2017, 20h00
pijaku

Patrick,
Désolé, je ne parle jamais comme ça.
Mais MERDE!
Tu as juste lancé le test sur le zoom qui, comme je le dit dans le message, ne modofie RIEN.
Dans mon message il y a 3-4 tests.
FAIS LES STP!
21/07/2017, 20h18
patricktoulon

re

j'ai lancé le test que tu m'a demandé c'est tout

post 76 utilisation de pointstoscreenpixels dans userform pour positionnement menu contextuel

post 616 vue sur déformation du zoom indéniable

post 621 vue du curseur positionné avec pointstoscreenpixels a tous les zoom

donne moi tes tests y a pas de soucis va y envoie la sauce

Franck le dernier que je t'ai montré c'est bien celui la non? que tu m'a demandé ? et bien tu vois le résultat en animation maintenant si il y en a d'autre envoie

par contre en aucun cas vous semblez avoir regardé ma derniere demo avec les deux chape sur une colonne qui justement a ce defaut et comment je l'ai rectifié non vous avez même pas regardé
sinon on aurait pas cette discussion mais une autre vous avez pas vraiment péter attention non plus au premier test shape qui vous affiche les données a l'interieur si vous aviez regarder le code qui va avec on aurait aussi cette autre discussion

Citation:

Quel N° de message, s'il te plait ?
(je n'ai pas souvenir de tests que tu aurais faits et montrés en se limitant au seul setcursorpos obtenu par la seule méthode PointsToScreenPixels. Car tout test qui montrerait le placement du userform et non le seul curseur serait entâché de vices autres éventuels).

@jacques tu décorne la ,retourne au post621 et regarde le code que j'ai utilisé la tu me prends pour un Champion Olympique de Natation hein !!!

Citation:

Envoyé par patricktoulon

j'ai lancé le test que tu m'a demandé c'est tout

Non.

Citation:

donne moi tes tests y a pas de soucis va y envoie la sauce
Franck le dernier que je t'ai montré c'est bien celui la non? que tu m'a demandé ?

Non!!!!!!!!!
Voici les 3 codes que je t'ai proposé, tu n'as fait que le premier.
Ne le refais plus hein!!!!! le premier. Fait les 2 autres!

Code test 1 (à ne plus refaire, tu l'as déjà fait.)
Il s'agit du test sur le zoom qui PROUVE que le zoom n’interagit pas.

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
Option Explicit
 
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 
Sub Test_PointsToScreenPixelsZOOM()
Dim i&, cible As Range
 
For i = 50 To 400 Step 20
    ActiveWindow.Zoom = i
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
End Sub

Code 2 on agit sur la hauteur d'une ligne
Celui-la, fais le, tu verras qu'à un moment, sur ta machine ça déconne *****

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
Option Explicit
 
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 
Sub Test_PointsToScreenPixelsHAUTEUR()
Dim i&, cible As Range, HauteurInitiale As Single
HauteurInitiale = Rows(3).RowHeight
    ActiveWindow.Zoom = 300
For i = 1 To 100
    Rows(3).RowHeight = Rows(3).RowHeight + 0.5
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
Rows(3).RowHeight = HauteurInitiale
    ActiveWindow.Zoom = 100
End Sub

Code 3 on agit sur la largeur d'une colonne
Celui-la, fais le, tu verras qu'à un moment, sur ta machine ça déconne *****

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
Option Explicit
 
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 
Sub Test_PointsToScreenPixelsLARGEUR()
Dim i&, cible As Range, LargeurInitiale As Single
 
LargeurInitiale = Columns(1).ColumnWidth
    ActiveWindow.Zoom = 300
For i = 1 To 100
    Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1
    Set cible = Range("B4")
    With Label1
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      .BackColor = RGB(255, 200, 200)
    End With
    With TextBox1
      .Top = cible.Offset(1, 0).Top
      .Left = cible.Left
      .BackColor = RGB(255, 255, 255)
     .Text = ActiveWindow.Zoom & "   " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width
    End With
    With ActiveWindow.ActivePane
        SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top)
    End With
    Stop
Next
Columns(1).ColumnWidth = LargeurInitiale
    ActiveWindow.Zoom = 100
End Sub

***** Si tu ne constates pas le problème, il n'y a pas 36 solutions...
...
...
C'est que tu mens, ou que tu as une très mauvaise vue, ou que tu n'as pas compris comment utiliser le code proposé.

!!!!Attention!!! L'utilisation de PointsToScreenPixels nécessite que l'application Excel (ou plutôt la feuille ou l'activewindow (comme vous voulez)) soit visible à l'écran.
Donc, pour les tests, met l'application en plein écran.

EDIT : reconnaître ses propres erreurs est un signe d'intelligence.
Si tes tests prouvent que j'ai tord (de vraies preuves hein!), je le reconnaitrai alors publiquement.

Mais bon, je n'y crois pas...

2 pièce(s) jointe(s)

re
donc test 2
Pièce jointe 296278

et maintenant test 3 attention ca va tres vite si tu veux je te le refait avec un sleep pour ralentir

Pièce jointe 296283

mais entre nous au vue de tes codes il est clair que l'on se comprends pas

ces test la ne servent strictement a rien

en tout cas chez moi c'est correcte

pour qu'il n'est pas d'ambiguïté je redonne tes code au quel j'ajoute le parent des controls label et textbox
au quel j'ajoute le maintient aussi les scroll a 1

test 1
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 Option Explicit Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long 'test 2 Sub Test_PointsToScreenPixelsHAUTEUR() Dim i&, cible As Range, HauteurInitiale As Single HauteurInitiale = Rows(3).RowHeight ActiveWindow.Zoom = 300 For i = 1 To 100 ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 Rows(3).RowHeight = Rows(3).RowHeight + 0.5 Set cible = Range("B4") With ActiveSheet.Label1 .Caption = "" .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) End With ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 With ActiveSheet.TextBox1 .Top = cible.Offset(1, 0).Top .Left = cible.Left .BackColor = RGB(255, 255, 255) .Text = ActiveWindow.Zoom & " " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width End With With ActiveWindow.ActivePane SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top) End With 'Stop Next Rows(3).RowHeight = HauteurInitiale ActiveWindow.Zoom = 100 End Sub
test 2
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 Option Explicit Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long 'test 3 Sub Test_PointsToScreenPixelsLARGEUR() Dim i&, cible As Range, LargeurInitiale As Single LargeurInitiale = Columns(1).ColumnWidth ActiveWindow.Zoom = 300 For i = 1 To 100 ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 Columns(1).ColumnWidth = Columns(1).ColumnWidth + 1 Set cible = Range("B4") With ActiveSheet.Label1 .Caption = "" .Top = cible.Top .Left = cible.Left .BackColor = RGB(255, 200, 200) End With ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 With ActiveSheet.TextBox1 .Top = cible.Offset(1, 0).Top .Left = cible.Left .BackColor = RGB(255, 255, 255) .Text = ActiveWindow.Zoom & " " & (ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Offset(0, 1).Left) - ActiveWindow.ActivePane.PointsToScreenPixelsX(cible.Left)) / cible.Width End With With ActiveWindow.ActivePane SetCursorPos .PointsToScreenPixelsX(cible.Left), .PointsToScreenPixelsY(cible.Top) End With Next Columns(1).ColumnWidth = LargeurInitiale ActiveWindow.Zoom = 100 End Sub
demain je les referais au ralenti pour être sur

en tout cas c'est une surprise pour personne que le curseur réponde bien avec pointstoscreenpixels en tout cas pas pour moi

certe logiquement on devrait penser que comme le userform n'est pas membre de l'activewindow le curseur ne l'ai pas non plus et devrait donc presentez un meme defaut j'ai pas la réponse a ca
mais ce dont je suis sur c'est point to screenpixels fonctionne très bien
si il ne vous fourni pas les réponse que vous attendez c'est pas forcement lui qui deconne

il y a un gros probleme d'arrondi c'est déjà un une belle coquille

je te prouverais demain une dernière fois que ppx ne devrait pas être toujours 1.3333.... ou 1.66666....7
prenez la peine de tester mon testshape 1

22/07/2017, 01h11
unparia

Citation:

en tout cas chez moi c'est correcte

Ah bon ? Et c'est toi, qui traite les autres de "miros" à tout bout de champ ? Incroyable !

A Franck . Tu auras demain matin une petite macro que je suis en train de terminer pour faciliter grandement mes tests en ce qui concerne la correction de PointsToScreenPixels ;)
22/07/2017, 08h06
patricktoulon

re

désolé la capture animée du test 2 de pijaku n'est pas représentative de ce que j'ai a mon écran

le testbox reste bien en dessous du label rose

je vais la ralentir

edit OK AU RALLENTI ON VOI BIEN UN LEGER DECALAGE POSITIF ET/OU NEGATIF DU CURSEUR

l'arrondi fait son effet visiblement
je vais tester les même sans aéro pour voir

Voilà un petit code pour faire sans douleur des tests de mon code précédent relatif à la correction à apporter pour que les coordonnées du curseur soient exxactes

- une feuille avec un bouton de commande commandbutton1 et un label Label1

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
Option Explicit
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
 
Private Sub CommandButton1_Click()
  Dim cible As Range, ppx As Double, i As Integer, ou As Single, titix As Long, titiy As Long, c As Long, r As Long
  Dim nbtests As Integer, attente As Integer
  nbtests = 10 ' ----->> choisir le nombre de tests à faire
  attente = 2 ' ------>> choisir le temps d'affichage en secondes qui vous sied
  Randomize
  With CreateObject("WScript.Shell")
     ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
  End With
  For i = 1 To nbtests
    Range("A1:A20").RowHeight = Int((50 * Rnd) + 10)
    Range("A1:AA20").ColumnWidth = Int((50 * Rnd) + 10)
    ou = Int((40 * Rnd) + 10)
    Rows(ou).RowHeight = Int((111 * Rnd) + 50) / 10
    ou = Int((4 * Rnd) + 1)
    Rows(ou).RowHeight = Int((40 * Rnd) + 40) / 10
    ou = Int((20 * Rnd) + 1)
    Rows(ou).RowHeight = Int((50 * Rnd) + 50) / 10
    ou = Int((4 * Rnd) + 1)
    Rows(ou).RowHeight = Int((40 * Rnd) + 40) / 10
    ou = Int((6 * Rnd) + 1)
    Rows(ou).RowHeight = Int((33 * Rnd) + 40) / 10
    ou = Int((20 * Rnd) + 1)
    Columns(ou).ColumnWidth = Int((50 * Rnd) + 50) / 10
    ou = Int((20 * Rnd) + 1)
    Columns(ou).ColumnWidth = Int((50 * Rnd) + 50) / 10
    ou = Int((20 * Rnd) + 1)
    Columns(ou).ColumnWidth = Int((10 * Rnd) + 40) / 10
    ou = Int((20 * Rnd) + 1)
    Columns(ou).ColumnWidth = Int((1# * Rnd) + 13) / 10
    DoEvents
    ou = Int((20 * Rnd) + 1)
    Columns(ou).ColumnWidth = Int((50 * Rnd) + 50) / 10
    r = Int((10 * Rnd) + 1)
    c = Int((10 * Rnd) + 1)
    Set cible = Cells(r, c)
    Label1.Caption = "        " & Replace(cible.Address, "$", "")
    DoEvents
    With ActiveWindow
      BlockInput True ' ---->> inhibition du clavier et de la souris
      cible.Show
      DoEvents
      With Label1
        .Font.Size = 14
        .Top = cible.Top
        .Left = cible.Left
        .BackColor = RGB(255, 200, 200)
        .Width = 400
      End With
      With ActiveWindow.ActivePane
        titiy = Int(cible.Top)
        titix = Int(cible.Left)
        SetCursorPos .PointsToScreenPixelsX(titix), .PointsToScreenPixelsY(titiy)
      End With
      Application.Wait Now + TimeValue("0:00:" & attente) ' attente pour donner le temps de voir
      BlockInput False ' --->> je réhabilité souris et clavier
    End With
  Next
End Sub

Ce code modifie aléatoirement des largeurs de colonnes et des hauteurs de lignes, puis cherche à placer le curseur à l'angle supérieur gauche d'une cellule choisie aléatoirement.
Sur ma machine : tous les placements se sont avérés corrects jusqu(à présent (j'en suis à près de 500 tests à raison de 50 lancements de 10 placements)
Merci des retours sur d'autres machines

22/07/2017, 08h30
unparia

Citation:

désolé la capture animée du test 2 de pijaku n'est pas représentative de ce que j'ai a mon écran

Ah ?
Je te retourne alors le "compliment" que tu m'as fait plus haut : change de version de ton OS, s'il te fait de telles blagues ! :lol:
22/07/2017, 08h53
patricktoulon

re

non pas du tout
ca veut dire tout simplement que setcursorpos attend les vrai position pixels de l'écran pris sur cible.propriété comme le userform et non la position prise sur la grille déformée

je te fait un truc et je reviens

je viens de faire la correction et visiblement c'est tellement petit que l'arrondi supprime la correction
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 With ActiveWindow.ActivePane l = (.PointsToScreenPixelsX([B4].Left) - .PointsToScreenPixelsX(0)) / [B4].Left / (ActiveWindow.Zoom / 100)' comme on ne touche pas le left dans l'exercice 2 il est toujours au bon ppx on ira pas chercher le ppx du registre 'MsgBox l T = (.PointsToScreenPixelsY([B4].Top) - .PointsToScreenPixelsY(0)) / [B4].Top / (ActiveWindow.Zoom / 100) vrai coefficient par rapport a la grille déformée de la verticale fauxPPX = l / T 'coefficient a ajouter a la position il sera en négatif ou positif 'MsgBox fauxPPX SetCursorPos .PointsToScreenPixelsX([B4].Left), .PointsToScreenPixelsY([B4].Top) * fauxPPX'on on multiplie par le coefficient de différence ' sur la feuille aucun changement pourtant a un moment on voit bien un grand écart donc fauxppx dépasse les 1.80 End With Sleep 800
mais bon ca ne fait que confirmer ce que je disais ppx ne doit pas toujours être 1.6666 ... ou 1.333333.....

et ca c'est pas pointstoscreenpixels qui fait cette erreur c'est l'argument qui lui est injecté a savoir (cible.propriété)qui te donne la dimension calculée et non celle de l'écran
on reviens toujours au même points

tout simplement par ce que vous n'acceptez pas que l'activewindow a l'écran est déformé dans tout les zoom y compris le 100%

chez moi le moment ou elle est le plus proche de la réalité est zoom 75% j'ai contrôlé 1 par 1

quelqu'un veux bien m'expliquer ce que l'on voit a l"écran hein ??

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
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 'test 2
Sub aaaaaaaaa()
Dim i&, cible As Range, HauteurInitiale As Single
HauteurInitiale = Rows(3).RowHeight
    ActiveWindow.Zoom = 300
   Set cible = ActiveSheet.Range("B3")
  ActiveSheet.Label1.Height = cible.Height
 For i = 1 To 100
   ActiveSheet.Range("B3").RowHeight = ActiveSheet.Range("B3").RowHeight + 0.5
   ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
     cible.Interior.Color = vbBlack
     With ActiveSheet.Label1
      .BackColor = vbYellow
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      '.Height = .Height + 0.5' ici l'augmentation n'est jamais effective
    .Height = HauteurInitiale + (0.5 * i)' obligé de faire comme ca pour l'augmentation = a l'augmentation row(3).height
       .Width = cible.Width
    End With
      ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
       Sleep 800
    'Stop
Next
Rows(3).RowHeight = HauteurInitiale
    ActiveWindow.Zoom = 100
ActiveSheet.Label1.Height = cible.Height
End Sub

alors dites moi qu'elle est la vrai représentation de la hauteur,celle du label ou de la cells ?

et la y a pas pointstoscreenpixels hein !!!!

d'ailleurs meme mieux

on s'en fou des dimensions si elles sont exact ou pas d'accords!!!

regardez les dimensions qui s'affichent dans les cellule A1 et A2

dites moi pourquoi j'obtiens des dimensions avec des décimales autre que 0.5
alors que le pas et de 0.5 pour les deux

je vous fait une belle capture animée en 3d si vous voulez

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
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
 'test 2
Sub aaaaaaaaa()
Dim i&, cible As Range, HauteurInitiale As Single
HauteurInitiale = Rows(3).RowHeight
    ActiveWindow.Zoom = 300
   Set cible = ActiveSheet.Range("B3")
  cible.RowHeight = 30
  ActiveSheet.Label1.Height = 30
 For i = 1 To 100
   ActiveSheet.Range("B3").RowHeight = ActiveSheet.Range("B3").RowHeight + 0.5
   ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
     cible.Interior.Color = vbBlack
     With ActiveSheet.Label1
      .BackColor = vbYellow
      .Caption = ""
      .Top = cible.Top
      .Left = cible.Left
      '.Height = .Height + 0.5
    .Height = HauteurInitiale + (0.5 * i)
    Cells(1, 1) = "label.height  " & .Height
    Cells(2, 1) = "cellule.rowheight " & cible.RowHeight
    .Width = cible.Width
    End With
      ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
       Sleep 800
    'Stop
Next
Rows(3).RowHeight = HauteurInitiale
    ActiveWindow.Zoom = 100
ActiveSheet.Label1.Height = cible.Height
End Sub

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

Fuseau horaire GMT +2. Il est actuellement 20h15.