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

Version imprimable

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

19/07/2017, 22h44
mjpmjp

bonjour,
j'avais posté une "anim" sur le décalage de ligne ICI Page 33 #655

W10 e10
@+JP
19/07/2017, 23h25
unparia

A Franck

Citation:

Oui...
Mais depuis le début de cette discussion, on ne peux émettre que des suppositions...

Ce ne sera pas une supposition, mais bel et bien une preuve.
Je suis trop fatigué pour en faire la démonstration totale (je la ferai demain), mais commence par ce tout petit constat :
EN MODE CREATION :
crée donc un userform et donne-lui ces propriétés (en mode création) :
Left = 100
Height = 100
Top = 400
Width = 100
Elles paraissent acceptées, n'est-ce pas ?
Lance maintenant l'application et exécute cette instruction :
Userform1.show
ferme le userform et retourne en mode création :
Réexamine maintenant les propriétés Top, Left, width et height -->> sans commentaires (VBA les a seulement alors corrigées) ;)
La suite pour demain...
19/07/2017, 23h58
pijaku

Jacques, si je pouvais te mettre +1000 je le ferais.

Mais, ce comportement, tout le monde en avait conscience, sans s'en rendre compte...
Je l'ai observé sur tout les UserForm que j'ai créé, ... sans me poser la vraie question : "pourquoi cette modification".
A vrai dire, des modifications de l'ordre de 0.25 à 0.75 pts ne m'ont jamais dérangé dans les fichiers que je créais...

Je pense qu'il faudrait ré-examiner le problème à la source : positionner le curseur de la souris par rapport à l'écran, et surtout par rapport à une cellule Excel (coin supérieur gauche).
Oublions un instant cet UserForm qui nous (vous) prend la tête en faisant des siennes lors de son affichage, juste pour voir...

Si l'on parvient à positionner le curseur sur le coin supérieur gauche d'une cellule, pour moi tout sera gagné.

On pourra éventuellement réfléchir (et il faudra absolument que cela fasse l'objet d'une autre discussion (on ne comprend plus rien à celle ci)) au positionnement de l'UserForm selon les "défauts" que tu soulignes ce soir....

Bises à tous

Amitiés à toi Jacques.

ps : bien entendu mon point de vue ne concerne que ma "petite" vision des choses.
N'oubliez pas, toutes et tous, que je n'y connais pas grand chose dans tout cela...

Ciao!!
;)
20/07/2017, 00h07
unparia

A Franck :

Citation:

Peut-être est-t'il temps de faire appel à d'autres langages de programmation.

Je penses notamment à VB.Net.

Quitte à paraître une fois de plus stupide, ne peux t'on pas demander à quelqu'un maîtrisant ce langage (whismeril me semble judicieux...) de :

tester la coordonnées dans l'écran d'un point quelconque,
de tester (en se référant à Excel) ce même point avec la méthode pointtoscreenpixel
de réaliser un autre test qui ne me vient pas parce que je n'y connais rien...

Je n'ai pas zappé cette partie de ton message.
Mais rechercher mes propres messages dans maintenant 49 pages et parmi ... 963 messages n'est pas chose aisée (quel capharnaüm !)

C'est exactement ce qui a été entrepris ailleurs (du moins presque exactement car nous avons fait mieux encore : placer un pixel sur l'écran à des coordonnées spécifiées et donc connues, puis travailler sur cette base). Et cela a été fait à l'aide de langages différents (y compris VB6)
Relis mes messages 401, 403 et 416.
A demain ...
20/07/2017, 00h45
patricktoulon

re

Citation:

@ Patrick :
C'est bien, mais comment calcule tu ton "plus"??????

le calcul tu l'a dans le code je récupère seulement le width -insidewidth +2
on voit bien la différence avec ou sans aero

jacques j'aurais cru que tu le savais déjà

quand tu change dynamiquement par vba ses propriétés s'inscrive dans le vbe
20/07/2017, 00h59
unparia

Patience Patrick, patience ...
Tu auras demain tout ce qui convient, comme dans la chanson "vous saurez tout sur le zizi" (et tu verras comment, et tu sauras pourquoi) :D
Ne t'emballe pas pour rien.

Et je me moquerai comme de l'an 14 de ce qui "s'inscrit dans le VBE"

De bon matin et reposé : revenons à ce qu'exposait mon message #962 --->>

Nous avons vu qu'étaient corrigées les valeurs saisies des 4 propriétés Left, Width, Top et Width.

Question : quelle en est donc la raison ?
Réponse : La raison en est que toutes les interventions graphiques sont forcément faites en échelle de pixels même si pour des raisons qui sont d'unicité et/ou de convivialité, VBA a choisi de travailler sur une échelle de points.

Or, une valeur exprimée en points ne correspond pas obligatoirement à un nombre entier de pixels. Que faire alors de la partie décimale de cette correspondance en pixels, puisqu'elle ne saurait être affichée, le pixel étant l'unité graphique affichable la plus petite ?
Il faut alors bien évidemment corriger la valeur d'origine. Et la correction est faite de cette manière :
Valeur d'origine -->> correspondance théorique en pixels --->> arrondissement à l'entier le plus proche --->> correspondance de cette dernière valeur en échelle de points.

Ce mécanisme étant maintenant bien compris, voici la fonction VBA qui le traduirait.
Dans cette fonction, pixparpoint est le nombre de pixels par point (que nous savons calculer).Pour ne pas encomprer ici, nous allons supposer que nous avons déterminé sa valeur et qu'elle est 1.333333 (pour un dpi de 96, donc) et v est le nombre d'unités en points à ajuster :
Code:

1 2 3 4 5 6 Private Function ajuste(v As Single) As Single pixparpoint = 1.333333 '---->> si 96 dpi -->> adapter à votre dpi v = v * pixparpoint ' --->> nb décimal de pixels ajuste = WorksheetFunction.Round(v, 0) ' --->> nb entier de pixels le plus proche ajuste = WorksheetFunction.Round(ajuste / pixparpoint, 2) ' ---> nb "ajusté" de points End Function
Exemple d'appel :
Code:

1 2 3 Dim toto As Single toto = ajuste(400) MsgBox toto
Faites des essais à comparer avec les résultats en agissant comme en mon message 962 -->> toujours bon.

Revenons maintenant à notre test. Nous y affections dynamiquement des valeurs de propriétés de l'userform. Il nous faut dès lors les corriger par notre fonction.
Ainsi (exemple bâclé avec XP sans aero ) :
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 Private Sub CommandButton1_Click() With UserForm1 .Top = 400 .Left = 100 .Width = 100 .Height = 100 .Show 0 .Show 0 End With With UserForm2 .Top = ajuste(UserForm1.Top) .Left = ajuste(UserForm1.Left) + ajuste(UserForm1.Width) .Show 0 MsgBox "nous sommes en accolement horizontal " .Left = ajuste(UserForm1.Left) .Top = ajuste(UserForm1.Top) + ajuste(UserForm1.Height) .Show 0 MsgBox "nous sommes en accolement vertical " .Top = ajuste(UserForm1.Top) + ajuste(UserForm1.Height) .Left = ajuste(UserForm1.Left) + ajuste(UserForm1.Width) .Show 0 MsgBox "voilà ce que nous voulions" End With End Sub
Voilà ... je vous laisse maintenant utiliser tout cela dans le code complet du sujet principal

Bonjour,

Patrick :
Désolé, je n'avais pas les yeux en face des trous.
Par contre, le + 2 est une variable d'ajustement?

Jacques,
Voici le code utilisé hier :

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
Option Explicit
 
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
 
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
 
Private Sub CommandButton1_Click()
  With UserForm1
    .Top = 100
    .Left = 100
    .Width = 200
    .Height = 200
    .Show 0
  End With
  placer_userform2
End Sub
 
Private Sub placer_userform2()
  Dim mUsf1 As RECT, mUsf2 As RECT
 
    mUsf1 = Correction(UserForm1)
    With UserForm2
        .Top = UserForm1.Top + UserForm1.Height + mUsf1.Top
        .Left = UserForm1.Left + UserForm1.Width + mUsf1.Left
        .Show 0
        'mUsf2 = Correction(UserForm2)
        '.Top = .Top + mUsf2.Top
        '.Left = .Left + mUsf2.Left
        .Width = 200
        .Height = 200
  End With
End Sub
 
Private Function Correction(Usf As Object) As RECT
Dim DblPpx As Double
Dim LngResult As Long, LngHwnd As Long
 
    With CreateObject("WScript.Shell")
        DblPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
    End With
    LngHwnd = FindWindow(vbNullString, Usf.Caption)
    LngResult = DwmGetWindowAttribute(LngHwnd, DWMWA_EXTENDED_FRAME_BOUNDS, Correction, LenB(Correction))
    If Correction.Left <> 0 Then
        Correction.Left = Usf.Left - (Correction.Left / DblPpx)
        Correction.Top = Usf.Top - (Correction.Top / DblPpx)
    End If
End Function

Si l'on dé-commente les 3 lignes, on obtient :

Pièce jointe 295518

20/07/2017, 08h08
unparia

Bonjour Franck
Applique ce que j'ai exposé dans mon message précédent et le petit décalage encore perceptible devrait totalement disparaître.

EDIT : et fais gaffe à ne pas te laisser tenter à "simplifier" les lignes du genre :

Code:

.Left = ajuste(UserForm1.Left) + ajuste(UserForm1.Width)

Car l'arrondi d'un total n'est pas égal à la somme des arrondis

Bon...
Pas sur d'avoir bien fait...
Voici le code :

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
Option Explicit
 
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
 
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
 
Private Sub CommandButton1_Click()
    Dim mUsf1 As RECT, mUsf2 As RECT
    With UserForm1
        .Top = 400
        .Left = 100
        .Width = 100
        .Height = 100
        .Show 0
        .Show 0
    End With
 
    mUsf1 = Correction(UserForm1)
    With UserForm2
        .Top = 0
        .Left = 0
        mUsf2 = Correction(UserForm2)
        .Top = ajuste(UserForm1.Top)
        .Left = ajuste(UserForm1.Left + UserForm1.Width + mUsf1.Left + mUsf2.Left)
        .Show 0
        MsgBox "nous sommes en accolement horizontal "
        .Left = ajuste(UserForm1.Left)
        .Top = ajuste(UserForm1.Top + UserForm1.Height + mUsf1.Top + mUsf2.Top)
        .Show 0
        MsgBox "nous sommes en accolement vertical "
        .Top = ajuste(UserForm1.Top + UserForm1.Height + mUsf1.Top + mUsf2.Top)
        .Left = ajuste(UserForm1.Left + UserForm1.Width + mUsf1.Left + mUsf2.Left)
        .Show 0
        MsgBox "voilà ce que nous voulions"
  End With
End Sub
 
Private Function ajuste(v As Single) As Single
Dim pixparpoint#
  pixparpoint = 1.333333 '---->> si 96 dpi -->> adapter à votre dpi
  v = v * pixparpoint ' --->> nb décimal de pixels
  ajuste = WorksheetFunction.Round(v, 0) ' --->> nb entier de pixels le plus proche
  ajuste = WorksheetFunction.Round(ajuste / pixparpoint, 2) ' ---> nb "ajusté" de points
End Function
 
Private Function Correction(Usf As Object) As RECT
Dim DblPpx As Double
Dim LngResult As Long, LngHwnd As Long
 
    With CreateObject("WScript.Shell")
        DblPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
    End With
    LngHwnd = FindWindow(vbNullString, Usf.Caption)
    LngResult = DwmGetWindowAttribute(LngHwnd, DWMWA_EXTENDED_FRAME_BOUNDS, Correction, LenB(Correction))
    If Correction.Left <> 0 Then
        Correction.Left = Usf.Left - (Correction.Left / DblPpx)
        Correction.Top = Usf.Top - (Correction.Top / DblPpx)
    End If
End Function

Et les résultats :

Accolement horizontal :
Pièce jointe 295519
Accolement vertical :
Pièce jointe 295521
Ce que nous voulions :
Pièce jointe 295524

20/07/2017, 08h40
unparia

Excellent, Franck
Plus de décalage du tout, y compris avec aero
Voilà une excellente nouvelle

NOTE : L'idée maîtresse est celle d'un membre d'une équipe tierce, que je salue (il comprend suffisamment le français et nous lit).
Seuls l'exploitation de cette idée et les calculs induits sont de mon cru.
20/07/2017, 08h48
Invité

Bonjour,

J'ai essayé le code de Franck sur mon poste, sa ne marche pas de mon côté. Le problème vient sûrement du fait que je sois en affichages multiples.

Avec le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub CommandButton1_Click()
Dim rectR As RECT, posP As POSITION, BoolRetour As Boolean
 
    posP = fPosCel(ActiveCell, BoolRetour)
    With UserForm2
        .StartUpPosition = 0
        .Show 0
        .Top = fAjuste(CSng(posP.Top))
        .Left = fAjuste(CSng(posP.Left))
    End With
    If BoolRetour = True Then
        rectR = fMarges(UserForm2)
        With UserForm2
            .Top = fAjuste(CSng(.Top + rectR.Top))
            .Left = fAjuste(CSng(.Left + rectR.Left))
        End With
    End If
End Sub

en DPI = 120, zoom 260% (juste pour mieux distinguer), j'obtiens un léger décalage (marginal) sur certaines lignes et certaines colonnes.

Image UserForm en C3 :
Pièce jointe 295551

image Userform en E5 :
Pièce jointe 295554

20/07/2017, 09h53
unparia

Bonjour Franck
Les valeurs des membres du rectangle doivent à mon sens être également ajustés

Pour être plus général : ajuster par la fonction tout ce qui résulte de calculs.

Jacques,

J'ai ajusté tout ce qui pouvait l'être.
Même résultat.

J'ai même testé ma fonction fPosCel avec fAjuste comme ceci :
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub Test_Ajuste() Dim Cel As Range, b As Boolean, d As Single, c As Single, e As Single For Each Cel In ActiveWindow.VisibleRange d = fPosCel(Cel, b).Top 'même chose avec Left e = d c = fAjuste(d) If c <> e Then MsgBox Cel.Address Next Cel MsgBox "fin" End Sub
Je n'ai eu que le mot fin...
Donc, la fonction qui retourne le positionnement des cellules est correcte, et ne nécessite pas d'ajustement.

En ce qui concerne les "marges" dues à aero, je l'ai désactivé donc elles sont = 0.
Pas besoin d'ajuster non plus.

bonjour a tous

j'arrive un peu tard
jacques pour que les choses soit clair dans mon esprit: ton pixparpoint tel qu'il est écrit dans ta fonction n'est pas bon on est d'accord? ou c'est un arrondi volontaire?
Code:

1 2 3 4 5 6 Private Function ajuste(v As Single) As Single pixparpoint = 1.333333 '---->> si 96 dpi -->> adapter à votre dpi v = v * pixparpoint ' --->> nb décimal de pixels ajuste = WorksheetFunction.Round(v, 0) ' --->> nb entier de pixels le plus proche ajuste = WorksheetFunction.Round(ajuste / pixparpoint, 2) ' ---> nb "ajusté" de points End Function

20/07/2017, 10h49
patricktoulon

Citation:

Envoyé par Oudouner

Bonjour,

J'ai essayé le code de Franck sur mon poste, sa ne marche pas de mon côté. Le problème vient sûrement du fait que je sois en affichages multiples.

Bonjour oudouner
comme je te l'ai déjà dis cela dépend de ton mode affichage double écran
tu a 2 possibilité
soit extension du bureau sur écran 2
soit écran supplémentaire
de cela dépend tes calcul

si tu ne sais pas le mode il suffit simplement de regarder en bas si tu a la barre des taches sur les deux écrans c'est que tu est en mode extension
au quel cas il va falloir que tu ajoute la dimension écran 2 dans tes calculs

si tu est en mode double écran il va te falloir peut être simplement ajouter dans tes valeur pixels la dimension complète de l'écran 1

je crois me souvenir mais je n'en suis pas sur que dans getsystemmetrics tu a les constantes (dimensions)des deux écrans réunis
a toi de vérifier
20/07/2017, 10h54
unparia

Citation:

Donc, la fonction qui retourne le positionnement des cellules est correcte, et ne nécessite pas d'ajustement

ce n'est pas cela, qui est mis en cause.
Ce qui peut influer est par contre le calcul des coordonnées après calcul de tes deux correctifs. Il implique que les coordonnées résultantes correspondent à un nombre entier de pixels.
Je n'ai pas tout ton code sous les yeux, mais il me semble (de mémoire) me rappeler que la fonction fMarges calcule entre autres des différences de coordonnées entre le usf et le rectangle étendu aero. A ce niveau, déjà (à vérifier) il parait prudent d'appliquer l'ajustement aux valeurs des coordonnées car un décalage pourrait résulter du fait de nombres non entiers de pixels.
Toutes ces coordonnées (tant du usf que du rectangle étendu) me paraissent devoir être "ajustées".
Cette fonction te retourne ensuite les deux "corrections" nécessaires, que tu vas appliquer à l'userform lui-même. A ce niveau également tu modifies les coordonnées en points du usf. "ajuste" ces coordonnées par la fonction avant leur application.
Important (dit plus haut) lorsque tu calcules en utilisant des valeurs à ajuster, fais tes calculs en utilisant l'ajustement de chaque valeur.
le résultat, par exemple, de ceci :
ajuste(toto - titi) est différent de ajuste(toto) - ajuste(titi)

A Patrick

Citation:

jacques pour que les choses soit clair dans mon esprit: ton pixparpoint tel qu'il est écrit dans ta fonction n'est pas bon on est d'accord? ou c'est un ar

rondi volontaire?

Il n'est là sous cette forme que pour ne pas "encombrer" trop, c'est tout. Et son arrondi ne provoque pas d'écart significatif dans notre "affaire"
Il est à remplacer en vrai (dans le code final) par :
Code:

1 2 3 4 Dim pixparpoint As Double, objWSH As Object Set objWSH = CreateObject("WScript.Shell") pixparpoint = objWSH.RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1) MsgBox pixparpoint

20/07/2017, 11h35
unparia

Pour ne rien laisser au hasard et être très précis :
Le dernier test que tu as fait (celui du placement d'un userform par rapport à un autre) et qui n'a rien à voir avec les cellules d'une feuille ni avec le zoom appliqué, a montré la fiabilité sans faille des fonctions de la librairie dwmapi.dll.
Ces fonctions permettent de placer exactement un userform à des coordonnées spécifiées.

Reste que si les coordonnées spécifiées ne sont pas elles-mêmes exactes, le userform, placé à ces coordonnées, sera placé à des coordonnées non exactes.
Et en ce qui concerne ce SEUL aspect (détermination des coordonnées excates d'une cellule), SEUL PointsToScreenPixels est concerné ! ;)

Les valeurs ne changent jamais avec la fonction Ajuste.
C'est comme si l'on multiplie puis divise par le même coefficient.
Je ne sais pas ce que j'ai fait...

Mon code d'appel avec les valeurs de Top en commentaires :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
Dim rectR As RECT, posP As POSITION, BoolRetour As Boolean
    posP = fPosCel(ActiveCell, BoolRetour)
    With UserForm2
        .StartUpPosition = 0
        .Show 0
        .Top = posP.Top
        'ICI .Top = 290,25
        .Left = posP.Left
        .Top = fAjuste(CSng(.Top))
        'ICI .Top = 290,25
    End With
    If BoolRetour = True Then
        rectR = fMarges(UserForm2)
        With UserForm2
            'ICI .Top = 290,25
            .Top = fAjuste(CSng(.Top)) + fAjuste(CSng(rectR.Top))
            'ICI .Top = 290,25
            .Left = fAjuste(CSng(.Left)) + fAjuste(CSng(rectR.Left))
        End With
    End If

et la fonction d'ajustement :

Code:

1
2
3
4
5
6
7
8
Public Function fAjuste(Valeur As Single) As Single
'Ajustement dû à l'arrondi de la conversion de points en pixels et inversement
Dim pixparpoint As Double
    pixparpoint = fPpx(Application.InchesToPoints(1))
    Valeur = Valeur * pixparpoint ' --->> nb décimal de pixels
    fAjuste = WorksheetFunction.Round(Valeur, 0) ' --->> nb entier de pixels le plus proche
    fAjuste = WorksheetFunction.Round(fAjuste / pixparpoint, 2) ' ---> nb "ajusté" de points
End Function

En fait, à cette ligne :

Code:

Valeur = Valeur * pixparpoint ' --->> nb décimal de pixels

j'obtiens systématiquement un nombre entier.

Je crois que je vais aller me reposer un peu
:zzz:

20/07/2017, 11h41
patricktoulon

re

jacques j'ai essayé avec DWM et avec la correction en dur c'est a dire 3.95 a la place de la fonction marges de pijaku

ca corrige mais pas a 100% et on a quand même un décalage sur certaine colonnes

la différence est de l'ordre de la dimension de l'ombrage

ca reste correcte pour le visuel
20/07/2017, 11h47
pijaku

Citation:

Envoyé par unparia

Reste que si les coordonnées spécifiées ne sont pas elles-mêmes exactes, le userform, placé à ces coordonnées, sera placé à des coordonnées non exactes.
Et en ce qui concerne ce SEUL aspect (détermination des coordonnées excates d'une cellule), SEUL PointsToScreenPixels est concerné ! ;)

Oui.
PointsToScreenPixels est responsable à lui seul de cette erreur, de ce décalage.
20/07/2017, 11h52
patricktoulon

re

c'est la ou l'on est pas d'accord pointstoscreenpixels fonctionne très bien chez moi en thème autre que aero aucun décalage séquentiel sur x colonne ou sur x lignes que se soit

je t'assure meme pas un pixel de difference ou alors c'est tellement petit que je le vois pas

j'ai même regarder l'écran avec ma loupe de ma trousse d' électronique qui grossi 1000 fois
20/07/2017, 11h54
unparia
Citation:

Je ne sais pas ce que j'ai fait...

Moi non plus, sans voir ce que tu as mis dans la fonction fPpx
Que te retourne donc (on va y voir clair)
Code:

1 2 pixparpoint = fPpx(Application.InchesToPoints(1)) msgbox pixparpoint
car si pas correct (et surtout si en plus entier lui-même) , ma foi ...

A Patrick : tu devrais vraiment relire attentivement mon message précédent :
DWM traite sur la base de coordonnées (quelles qu'elles soient) spécifiées. Et il le fait sans faille (le test l'a montré). Si les coordonnées qu'il traite et lui sont communiquées ne sont pas exactes, ce n'est pas DWM qui en est responsable, hein ...

fPpx est bonne.
Cette fonction c'est celle avec l'objet Shell.
Elle me retourne 1,33333333333333333333333333

Je voulais en avoir le coeur net.
Alors....
J'ai testé PointsToScreenPixels, comme ceci :

Tout d'abord :
> Un gros zoom pour bien positionner le curseur.
> trouver une cellule ou il y a un décalage lors du placement de l'Userform
>> si inexistante alors vous n'avez pas de souci...

Positionner le curseur dans l'angle supérieur gauche de la dite cellule activée, lâcher la souris quand c'est parfait, puis lancer la macro suivante grâce à Alt+F8.
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 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Public Type POSITION Left As Double Top As Double End Type Sub aaa() Dim P As POINTAPI Dim pos As POSITION Dim C As Range, dblPpx As Double Dim Msg As String GetCursorPos P Msg = "curseur positionné à : " & P.X & " " & P.Y & vbCrLf With CreateObject("WScript.Shell") dblPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 End With Set C = ActiveCell With ActiveWindow.ActivePane pos.Left = .PointsToScreenPixelsX(C.Left) pos.Top = .PointsToScreenPixelsY(C.Top) SetCursorPos pos.Left, pos.Top Msg = Msg & "Calculé à : " & pos.Left & " " & pos.Top End With MsgBox Msg End Sub
J'ai bien une différence, pouvant même être importante (4 ou 5).

20/07/2017, 12h05
patricktoulon

re

après sincèrement personne jusque la n'était arrivé a ce résultat je pense que l'on peut être content de notre travail et dieux sait qu'il y a moultes exemples tous plus faux les uns que les autres
on a bien bossé

je voudrais attirer votre attention une dernière fois sur GetSystemmetrics(56)/ppx

Citation:

Return the method used to display minimized windows. The return value is a combination of two of the following flags, one specifying a starting position for the minimized icons
and another specifying the direction in which new ones are added:

c'est a votre bon vouloir

Citation:
Envoyé par pijaku
fPpx est bonne.
Cette fonction c'est celle avec l'objet Shell.
Elle me retourne 1,33333333333333333333333333

Je voulais en avoir le coeur net.
Alors....
J'ai testé PointsToScreenPixels, comme ceci :

Tout d'abord :
> Un gros zoom pour bien positionner le curseur.
> trouver une cellule ou il y a un décalage lors du placement de l'Userform
>> si inexistante alors vous n'avez pas de souci...

Positionner le curseur dans l'angle supérieur gauche de la dite cellule activée, lâcher la souris quand c'est parfait, puis lancer la macro suivante grâce à Alt+F8.
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 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Public Type POSITION Left As Double Top As Double End Type Sub aaa() Dim P As POINTAPI Dim pos As POSITION Dim C As Range, dblPpx As Double Dim Msg As String GetCursorPos P Msg = "curseur positionné à : " & P.X & " " & P.Y & vbCrLf With CreateObject("WScript.Shell") dblPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 End With Set C = ActiveCell With ActiveWindow.ActivePane pos.Left = .PointsToScreenPixelsX(C.Left) pos.Top = .PointsToScreenPixelsY(C.Top) SetCursorPos pos.Left, pos.Top Msg = Msg & "Calculé à : " & pos.Left & " " & pos.Top End With MsgBox Msg End Sub
J'ai bien une différence, pouvant même être importante (4 ou 5).
c'est bien ce que je dis depuis un moment en zoom il y a déformation proportionnelle même si c'est pas le zoom le responsable mais bien le thème
puisque ton test chez moi en thème classique Windows est nikel

A Franck. Tu me troubles, là ...
Avant même de parler du reste :
Tu avais écrit :

Citation:

En fait, à cette ligne :

Valeur = Valeur * pixparpoint ' --->> nb décimal de pixels

j'obtiens systématiquement un nombre entier.

Ce qui est impossible si pixparpoint = 1.33333333333...
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Private Sub CommandButton5_Click() MsgBox fAjuste(100) End Sub Public Function fAjuste(Valeur As Single) As Single 'Ajustement dû à l'arrondi de la conversion de points en pixels et inversement Dim pixparpoint As Double pixparpoint = 1.333333 'fPpx(Application.InchesToPoints(1)) Valeur = Valeur * pixparpoint ' --->> nb décimal de pixels fAjuste = WorksheetFunction.Round(Valeur, 0) ' --->> nb entier de pixels le plus proche fAjuste = WorksheetFunction.Round(fAjuste / pixparpoint, 2) ' ---> nb "ajusté" de points End Function

20/07/2017, 12h19
unparia

Citation:

c'est bien ce que je dis depuis un moment en zoom il y a déformation proportionnelle même si c'est pas le zoom le responsable mais bien le thème
puisque ton test chez moi en thème classique Windows est nikel

Et là, Patrick, tu te contredis.
C'est PointsToScreenPixelsX/Y qui gère à ce niveau-là. Et sa mission est de retourner les coordonnées en pixels à l'écran, quelle que soit la situation (zoom ou pas, etc ...)
Si tu dis que l'utilisation de ta "loupe" a montré que le curseur était bien placé (par setcursorpos), les coordonnées retournées sont celles qu'utilisera DWM (qui se moque d'où elles proviennent. Ce n'est pas son affaire). Mais si pas rigoureusement celles souhaitées, DWM les utilisera également (et si elles ne sont pas les bonnes, hein ...). En d'autres terme : DWM OBEIT et ne discute point

Citation:

Envoyé par unparia

A Franck. Tu me troubles, là ...
Avant même de parler du reste :
Tu avais écrit :

Ce qui est impossible si pixparpoint = 1.33333333333...

C'est ce que je me suis dit également...
Mais, comme on ne lui envoie que des valeurs en points, la conversion (x pixparpoint), me donne systématiquement un nombre entier.
Avec cette fonction :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Public 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 Public Function fAjuste(Valeur As Single) As Single 'Ajustement dû à l'arrondi de la conversion de points en pixels et inversement Dim pixparpoint As Double, V As Single V = Valeur pixparpoint = fPpx(Application.InchesToPoints(1)) Valeur = Valeur * pixparpoint ' --->> nb décimal de pixels Debug.Print "V : " & V & " Valeur : " & Valeur fAjuste = WorksheetFunction.Round(Valeur, 0) ' --->> nb entier de pixels le plus proche fAjuste = WorksheetFunction.Round(fAjuste / pixparpoint, 2) ' ---> nb "ajusté" de points End Function
J'obtient ce type de résultats :

Citation:

V : 279 Valeur : 372
V : 0 Valeur : 0
V : 279 Valeur : 372
V : 0 Valeur : 0
V : 213,75 Valeur : 285
V : 194,25 Valeur : 259
V : 0 Valeur : 0
V : 194,25 Valeur : 259
V : 0 Valeur : 0
V : 213,75 Valeur : 285
V : 223,5 Valeur : 298
V : 335,25 Valeur : 447

Et donc, comme il n'a rien à arrondir, le résultat de la fonction est systématiquement identique à la valeur d'entrée...

En même temps, quand je prend ma calculatrice et que je fais :
279*1.333333333333, j'obtiens 371.999999999991, que Round va transformer gaiement en 372...

EDIT : oui pour 100 la fonction "fonctionne". Mais ne pas oublier qu'on ne lui envoie que des coordonnées.
Tu peux tester ceci :

MsgBox Ajuste(335,25)

20/07/2017, 12h32
unparia
La valeur de sortie ("ajustée") est bien évidemment égale à celle d'entrée lorsque celle d'entrée correspond à un nombre entier de pixels (et donc accepté et laissé tel quel)
C'est un aspect dont il faut savoir profiter.
Je m'explique :
l' "ajustement" n'est vraiment nécessaire que lorsque l'on fait varier ou que l'on définit dynamiquement les propriétés de positionnement. Il ne l'est pas dans les autres cas.
L'aspect exposé au 1er paragraphe nous permet tout simplement d'éviter de traiter différemment selon qu'intervention dynamique ou non. Le code est toujours le même et ne fait aucu_n dégât (l' ajustement ne modifiant la valeur que si nécessaire et la laissant telle quelle si déjà bonne ;)).

Regarde :
Code:

1 2 3 4 5 Dim toto As Single toto = fAjuste(100) MsgBox toto ' --->>> ajuste car nécessaire toto = fAjuste(toto) ' --->> laisse maintenant intacte la valeur d'entrée (puisque acceptée) MsgBox toto

même si cela vous intéresse pas visiblement

getsystemmetrics(56) vous est donné pour un dpi de 96 soit 100%

attention uniquement sur W7 donc chez toi pijaku ca doit être bon
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Sub testget56() With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With ppxuniversel = 4 / 3 '=1.33333333333333 coeffppx1TOppx2 = ppx / ppxuniversel 'cooefficient ppxdpi to ppx universel If ppx <> ppxuniversel Then plus = GetSystemMetrics(56) / coeffppx1TOppx2 / ppx Else plus = GetSystemMetrics(56) / ppx End If MsgBox plus With UserForm1 .Show 0 .Left = plus + ActiveWindow.ActivePane.PointsToScreenPixelsX(ActiveCell.Left) / ppx .Top = plus + ActiveWindow.ActivePane.PointsToScreenPixelsY(ActiveCell.Top) / ppx End With End Sub
une personne avec qui j'étais en discussion dans la communauté Windows(forum) me criait haut et fort que get....(56) devait fonctionner

l'erreur que je faisait était de la diviser par ppx du dpi alors que c'était le ppx universel

attention certaine données de getsystemmetrics son donnée de la même manière pour dpi 96 uniquement je l'ignorais :oops:

20/07/2017, 13h03
pijaku

Citation:

Envoyé par patricktoulon

attention uniquement sur W7 donc chez toi pijaku ca doit être bon

Ben non.
Car chez moi PointsToScreenPixels ne fonctionne pas correctement.
Avec ta Sub :
Sans aero

Pièce jointe 295639

Et avec :

Pièce jointe 295643
20/07/2017, 13h19
patricktoulon

re

a bon voila autre chose maintenant

sais tu la raison pour la quel ptscpx ne fonctionne pas correctement chez toi

chez moi fixe et portable fonctionnent pareil résultat identique
que donne get...(56) chez toi
EDIT::!!!!!
puré je vois rien tellement c'est petit en dpi 96 :ptdr:
en effet tu dois etre en dpi 96 cela donne 6 chez moi

ce qui est étonnant quand je divise ce 6 par 1.25 qui correspond au coefficient dpi 120 to dpi 96 je retombe sur mes 4.8

je reviens je me remet en 120
20/07/2017, 13h44
mjpmjp

1 pièce(s) jointe(s)

bonjour,
Pièce jointe 295656

@+JP

pijaku
je suis curieur de savoir si tu a la même erreur que moi avec mon (+1) que jacques n'aime pas

pointstoscreenpixels te donne -t-il 1 de moins comme moi sur une seuls cellule(ou un seul point de l'écran )

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub testpijaku()
 
    [A1].Select
    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)
    wa1 = (.ActivePane.PointsToScreenPixelsX([A1].Width) - .ActivePane.PointsToScreenPixelsX(0)) / (.Zoom / 100)
    Wa1bis = [A1].Width * ppx
    deux_cells = (.ActivePane.PointsToScreenPixelsX([A1:B1].Width) - .ActivePane.PointsToScreenPixelsX(0)) / (.Zoom / 100)
 
    End With
    MsgBox wactivecell & vbCrLf & w2 & vbCrLf & wa1 & vbCrLf & Wa1bis & vbCrLf & deux_cells
End Sub

20/07/2017, 14h02
pijaku

J'obtiens :
81
81
81
81
161
20/07/2017, 14h12
patricktoulon

re

INCROYABLE!!!!
tu a exactement l'erreur inverse de moi c'est un truc de fou
font elles bien 81 pixel tes cellules
chez moi c'est
---------------------------
Microsoft Excel
---------------------------
103
104
103
104
208
---------------------------
OK
---------------------------
20/07/2017, 14h16
pijaku

Les résultats sont corrects.
Pour les cellules testées.
A1 : 81 et B1 : 80

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

Fuseau horaire GMT +2. Il est actuellement 04h23.