teste de position userform

[patricktoulon]

Bonjour a tous j'aurais besoins de vos retours sur la postion du userform
ces retours doivent s'accompagner de la version excel utilisé et la version de window
exemple chez moi emplacement B3 correcte , W7 , excel 2007
je vous remercie par avance pour le temps que vous prendrez pour ma petite experience
voici le code a tester
'--------------------------------------------------------------------------
Sub test20()
Dim pppx#, plus#, z#
With ActiveWindow.ActivePane
pppx = (.PointsToScreenPixelsX(ActiveSheet.[A1].Width) - .PointsToScreenPixelsX(0)) / ActiveSheet.[A1].Width
L1 = (.PointsToScreenPixelsX([A1].Left) / pppx)
R1 = (.PointsToScreenPixelsY([A1].Top) / pppx)
End With
z = (ActiveWindow.Zoom / 100)
With UserForm1
.Show 0
plus = .Width - .InsideWidth
.Left = (L1 + [B3].Left + (plus / z)) * z
.Top = (R1 + [B3].Top + ((plus / 2) / z)) * z
End With
End Sub
'---------------------------------------------------------------------------

 

[Roland_M]

EDIT: j'ai supprimé car pas encore au point !
j'ai fais d'autres découvertes, alors ... en attendant mieux ...
à bientôt j'espère !?

 

[patricktoulon]

CADEAU POUR TOUS
l'astuce qui regle tout ce qui nous a induit en erreur jusque la est en gras
------------------------------------------------------------------------------
Sub test_sans_api()
Dim X As Double, Y As Double, Z As Double, version, ppx As Double
With ActiveWindow
Z = (.Zoom) / 100
If Val(Right(Z, 1)) Mod 2 <> 0 And Z <> 1 Then Z = Z + 0.1
ppx = (.ActivePane.PointsToScreenPixelsY(3) - .ActivePane.PointsToScreenPixelsY(0)) / 3
X = .ActivePane.PointsToScreenPixelsX([d3].Left)
Y = .ActivePane.PointsToScreenPixelsY([d3].Top)
End With
Version = Round(Val(Split(Application.OperatingSystem, " ")(3)))
suppleft = IIf(Version > 6.01 Or Version = 0, "-5", 4.4)
supptop = IIf(Version > 6.01 Or Version = 0, 0, 4.4)
With UserForm1
.Show 0
.Left = (X / ppx) * Z + suppleft
.Top = (Y / ppx) * Z + supptop
End With
End Sub
-----------------------------------------------------------------------------------------------
j'ai demarrer cette recherche de solution il y a plus d'un mois je ne compte plus les nombre de versions de code que j'ai pu écrire et tester j'ai découvert cela cette nuit et la lumière fut

 

[Roland_M]

Bonjour tout le monde,

Félicitation Patrick pour ta ténacité !

mais dis moi, ici:
ppx = (.ActivePane.PointsToScreenPixelsY(3) - .ActivePane.PointsToScreenPixelsY(0)) / 3
X = .ActivePane.PointsToScreenPixelsX([d3].Left)
Y = .ActivePane.PointsToScreenPixelsY([d3].Top)

perso je me sers d'une cellule qui bien souvent est celle active mais pas forcément, Rng
alors je traduis comme ceci:
ppx = (.ActivePane.PointsToScreenPixelsY(3) - .ActivePane.PointsToScreenPixelsY(0)) / 3
X = .ActivePane.PointsToScreenPixelsX(Rng.Left)
Y = .ActivePane.PointsToScreenPixelsY(Rng.Top)

question, ici j'ai un doute avec ppx:
ppx = (.ActivePane.PointsToScreenPixelsY(3) - .ActivePane.PointsToScreenPixelsY(0)) / 3
pour mon utilisation, dois je modifier ?
est-ce, comme je le pense, en rapport avec le nombre de lignes ? car j'ai essayé avec Rng.Row mais ce n'est plus correcte !


EDIT: par-contre ...

RE EDIT: comme je suis tenace moi aussi, j'ai solutionné tout ceci et en utilisant les deux formules de Patrick !
voir message suivant !

 

[Roland_M]

Bonsoir tout le monde,

voir cette nouvelle version, très allégée, en utilisant les deux formules principales de PatrickToulon
concernant PointToPixel et PosTop/Left

voir essais sur d'autres versions excel !? perso Vista/Win7 Excel 2007
j'ai tout testé, zoom, scrolling, et surtout volets figés ou fractionnés qui posaient problèmes !
ainsi que le ScreenUpdating qu'il faut prévoir à true !

encore merci à Patrick !

 

[MJ13]

Bonjour à tous

Merci Patrick et Roland pour ces toutes dernières solutions.

Je suis parti sur une autre piste en détectant la position de la souris. Il faudra vérifier sur votre configuration le coefficient à appliquer. Sur plusieurs configurations, j'ai mis soit 0,60 ou 0,75. Mais on peut facilement trouver la bonne valeur en faisant évoluer sa valeur avec la toupie et en testant avec un click droit sur la feuille.

 

[patricktoulon]

re en voila une encore sans api windows qui devrait convenir a tout le monde
'--------------------------------------------------------------------------
Sub ultimatemethode()
With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72: End With
With ActiveWindow
Z = .Zoom / 100
X = .ActivePane.PointsToScreenPixelsX([D3].Left) / ppx
Y = .ActivePane.PointsToScreenPixelsY([D3].Top) / ppx
End With
With UserForm1
.Show 0
.Left = X -5'(-5 pour ceux qui sont au dessus de W7 et 2007 sinon "+4.4"
.Top = Y '(rien pour ceux qui sont au dessus de W7 et 2007 sinon "+4.4"
End With
End Sub
'------------------------------------------------------------------------------------------
en fait le soucis venait du fait que pointstoscreenpixelx(0) ne gere pas la profondeur d'écran donc selon le zoom et le DPI WALOUH!!!
alors je vais chercher le coeff ailleurs dans la base de registre qui est calculer sur le dpi inscrit /72
et basta c'est tout bon reste le -5 , 0 , 4.4 selon les version Windows/office

 

[Roland_M]

Bien le bonjour à tous,

Notre ami Patrick est bien sympa avec ses codes que j'apprécient beaucoup,
mais que nenni de tout ce que l'on peut proposer y compris des questions sans réponse !?
peut être d'ailleurs n'a t'il rien vu !?
il apparaît puis il disparaît ! communications, échanges, impossible !?

 

[Nicolas JACQUIN]

Bonjour Roland,
il va répondre, ça fait plus d'un mois qu'on ai dessus, à ajuster en fonction des systèmes et versions, il devrait pas tarder à répondre pour sortir le code final
Bien amicalement

 

[patricktoulon]

allons Rolland que t'arrive t il? je suis la ,je peaufine et cherche maintenant une méthode globale qui remplacerait mon switch
j'ai testé tes essais de fichier et chez moi c’était pas bon du tout même avec la possibilité de la toupie
arriver a un moment c'est soit trop grand soit trop petit

j'ai eu du mal a comprendre ou était l'erreur avec pointstoscreenpixels pour le DPI
et effectivement l'erreur était la sous mes yeux elle ne gère tout simplement pas la profondeur d'écran dpi en dpi 96 ,mais plus on monte en dpi plus le résultat est proche mais pas exact
c'est cela qui nous trompe depuis le debut car perso je travaille en 120 DPI qui est plus facile a corriger qu'en 96 DPI
j'ai donc abandonné la recherche ppx par le DPI avec pointstoscreenpixels
j'ai donc bifurqué sur l accès a la base de registre pour récupérer tout simplement le dpi pour en sortir le ppx (coefficient points to pixel)
il nous reste le switch pour le petit décalage selon les versions dont je voudrais bien découvrir ou ces mesures peuvent elles êtres prises
en attendant voila une version qui fonctionne dans n'importe quel position avec
2007 sur W7
W8.1 64 2013 32
W10 64 2013 64
W10 64 2016 32
quand j'aurais tout les retours possibles je pourrais peut être trouver la donnée sans passer par un switch
en tout cas je saurais peut etre ou chercher

next version
Sub version_ALLWin_Off()
Dim ppx#, version As String, X#, Y#, SuppLeft#, Suppop#
With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72: End With
version = CStr(Val(Split(Application.OperatingSystem, " ")(3)) & "-" & Val(Application.version))
MsgBox version
SuppLeft = Switch(version = "6,01-12", 4, version = "0-15", 0, version = "10-16", -5, version = "10-15", -5, version = "10-14", 0)
supptop = Switch(version = "6,01-12", 4, version = "0-15", 0, version = "10-16", 0, version = "10-15", 0, version = "10-14", 0)
With ActiveWindow
X = .ActivePane.PointsToScreenPixelsX([D3].Left) / ppx
Y = .ActivePane.PointsToScreenPixelsY([D3].Top) / ppx
End With
With UserForm1
.Show 0
.Left = X + SuppLeft
.Top = Y + supptop
End With
End Sub

pour info voici un capture d’écran de ton dernier essaie sur W7 2007 comme tu peut le voir entourer en bleu c'est pas bon

 

[Roland_M]

Bonjour

Salut à toi Patrick !
Ben je ne comprends pas du tout comment tu peux avoir ce résultat !?
car c'est avec tes fonctions et chez moi ça fonctionne parfaitement avec:
Excel 2007 et Win7, Vista et même Xp

bon, maintenant ce n'est pas 4 points de + ou de - qui pose un véritable problème !?
on est sur la cellule et c'est bon quoi !

à propos de Switch, s'il n'y a pas la chaîne Version dans les choix, c'est le plantage !
perso j'utilise Select Case:

'2007 /XP "5,01-12" Top+0 Left+0
'2007 /Vista "6-12" Top+4 Left+4
'2007 /W7 "6,01-12" Top+4 Left+4
'2013 32 W8.1 64 !?
'2013 64 W10 64 !?
'2016 32 W10 64 !?

Version = CStr(Val(Split(Application.OperatingSystem, " ")(3)) & "-" & Val(Application.Version))
Select Case Version
Case "6-12", "6,01-12": CadreTop = 4: CadreLeft = 4
Case "10-15", "10-16": CadreTop = 0: CadreLeft = -5
Case Else: CadreTop = 0: CadreLeft = 0 '< "10-14", "0-15", "5,01-12" ...!?
End Select

 

[Patrice33740]

Bonjour Patrick

Tu pinailles pour quelques points mais est-ce que tu envisages de faire un code qui fonctionne aussi avec du scroll quand les volets sont figés ?

 

[MJ13]

Bonjour à tous

Voici la solution ultime pour aligner un Userform sur une cellule.

Beaucoup de possibilités dans le fichier, à vous de choisir.

Merci à tous pour votre implication.

 

[patricktoulon]

Bonjour Mj13 aucun des exemple n'est bon chez moi
il est maintenant bien determiné les cause du probleme

1. l'agrandissement par le zoom ou tout autre procédé de ce que tu vois a l’écran est déformé proportionnellement
2. selon les version après XP et selon le thème utilisé ca peut varier
3. la puissance de carte graphique peut jouer aussi sur le résultat

alors api pour api autant utiliser la bonne et en ce qui nous concerne c'est la dwmapi.dll qui gere justement l'affichage de aero et les theme W10 et compagnie avec DWM.exe

'---------------------------------------------------------------------------------------------
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 Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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



Sub testDWM()
Dim L#, T#, R As RECT, ppx#

With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
With UserForm1
.StartUpPosition = 0
.Show 0
.Top = ((ActiveWindow.ActivePane.PointsToScreenPixelsY(ActiveCell.Top)) / ppx) '+ 3.75
.Left = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(ActiveCell.Left)) / ppx) ' + 3.75 ' - 5
End With
R = Marges(UserForm1.caption, UserForm1.Left, UserForm1.Top, ppx)
L = R.Left
T = R.Top
With UserForm1
.Top = .Top + T
.Left = .Left + L
End With
End Sub



Public Function Marges(Lcaption$, L#, T#, ppx#) As RECT
Dim rectangle As RECT, handleusf As Long ' ----->> le rectangle étendu que l'on veut extraire (aero, donc)
Version = CStr(Val(Split(Application.OperatingSystem, " ")(3)))
Marges.Left = 0: Marges.Top = 0
If Version = 0 Or Version > 6 Then
handleusf = FindWindow(vbNullString, Lcaption)
DwmGetWindowAttribute handleusf, DWMWA_EXTENDED_FRAME_BOUNDS, rectangle, LenB(rectangle)
Marges.Left = IIf(rectangle.Left / ppx <> 0, L - (rectangle.Left / ppx), 0)
Marges.Top = IIf(rectangle.Top / ppx <> 0, T - (rectangle.Top / ppx), 0)
MsgBox Marges.Left
End If
End Function
'-----------------------------------------------------------------------------------------------------
voila bien dommage que l'on puisse le faire sans api

 

[MJ13]

Bonjour Patrick

Merci pour le retour.

Sur toutes les configs que j'ai testé, tout fonctionne bien à condition de savoir adapter la routine qui va bien, (j'ai pas trop testé avec Excel 2007, vu qu'il se fait un peu vieux) .

Bon après, mon but c'est plutôt d'avoir un Userform qui se cale sur la souris ou sur la cellule active.