Discussion :

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

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

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

[patricktoulon]

bonjour franck
oui certainement une difference de config

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

[pijaku]

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

[unparia]

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 :

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
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.

[patricktoulon]

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

[unparia]

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

[patricktoulon]

franck voila ta demo


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 !!!

[unparia]

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

[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!

[patricktoulon]

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

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 !!!

[pijaku]

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

Non.

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 :

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

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

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
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...

[patricktoulon]

re
donc test 2



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



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 :

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

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

[unparia]

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

[patricktoulon]

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

[unparia]

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 :

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

[unparia]

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 !

[patricktoulon]

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

[patricktoulon]

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

Code :

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

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

[patricktoulon]

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

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
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 !!!!

[patricktoulon]

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 :

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