Autres Resolution USERFORM et Ecran

[FOUQUET Yves]

Bonjour,

Quelqu'un peut-il me dire si ces lignes de code me permettront d'adapter sur n'importe quel ordinateur la taille de l'Userform à la résolution de l'écran et la taille de Listbox à la taille de l'Userform ?

Je teste chez moi ça a l'air OK mais sur un écran avec d'autres résolution ???

Merci de vos réponses.
Bonne soirée.

LargeurEcran = GetSystemMetrics(0)
HauteurEcran = GetSystemMetrics(1)
HauteurUserf = HauteurEcran * 0.75
LargeurUserf = LargeurEcran * 0.75
Me.Move 1, 1, LargeurUserf, HauteurUserf  'pour tout modifier
ListBox1.Width = LargeurEcran * 0.74
ListBox1.Height = HauteurEcran * 0.62

 

[Dudu2]

Ok, je ne connaissais pas cette méthode pour lire une valeur de registre. Merci pour l'astuce.
Je pense que tu veux dire 1,66666666666667.
Une fois captée par le Shell, à garder en variables module ou en Static.

 

[patricktoulon]

re
ou tu la laisse comme tel (une fonction) et tu t'en sert quand tu veux
on peut considérer la fonction comme une variable
ca sert a rien de stoker une variable

 

[Dudu2]

Je voulais surtout éviter l'exécution répétée d'un Shell et d'une lecture du registre.
Dommage qu'on n'ait pas cette information dans un GetSystemMetrics.

 

[patricktoulon]

re
oui c'est vrai

 

[patricktoulon]

tiens si tu veux faire peter la caption
n'oublie pas de mettre un bouton fermer 😉

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

#End If
Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type

Function ptopx()    'fonction coeff point to pixel
    With ActiveWindow.ActivePane: ptopx = (.PointsToScreenPixelsX(100) - .PointsToScreenPixelsX(0)) / 100: End With
End Function

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Activate()
    MsgBox GetSystemMetrics(6)
    Dim r1 As RECT, r2 As RECT
    GetWindowRect GetDesktopWindow, r1    'le rectangle de l'ecran
    GetWindowRect FindWindow("shell_traywnd", ""), r2    'le rectangle de la barre des taches
    r1.Bottom = r2.Top + GetSystemMetrics(15) - GetSystemMetrics(5) ' on remplace le bottom de r1 par le r2.top(top taskbar)
    r1.Top = r1.Top - (GetSystemMetrics(15)+  GetSystemMetrics(5))
    'Me.Move 0, 0, Int(r1.Right / ptopx), Int(r1.Bottom / ptopx)    'et on place le userform
    Me.Move 0, r1.Top / ptopx, Int(r1.Right / ptopx), Int(r1.Bottom / ptopx)    'et on place le userform pas de caption

End Sub

 

[patricktoulon]

tu en veux une encore plus simple?
pas de soucis

Option Explicit
#If VBA7 Then
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If
Function ptopx()    'fonction coeff point to pixel
    With ActiveWindow.ActivePane: ptopx = (.PointsToScreenPixelsX(100000) - .PointsToScreenPixelsX(0)) / 100000: End With
End Function

Private Sub UserForm_Activate()
Me.Move 0, 0, GetSystemMetrics(0) / ptopx, (GetSystemMetrics(1) - GetSystemMetrics(14) - GetSystemMetrics(7)) / ptopx
'Me.Move 0, 0, GetSystemMetrics(0) / ptopx, (GetSystemMetrics(1) / ptopx) - (GetSystemMetrics(21) + GetSystemMetrics(7))
End Sub

j'arrete là sinon demain y a plus de code 😉😛😛😛

 

[Dudu2]

Bonjour,
Alors là tu chipotes 😉
Reste toujours <Alt + F4> pour se sortir des mauvais pas quand on ne sait plus où on a placé le UserForm 😱

J'ai finalisé ma version qui est moins concentrée que la tienne et qui donne toujours 3 options de positionnement.
Sans toujours comprendre pourquoi un GetWindowRect GetActiveWindow, R sur une fenêtre maximisée donne des valeurs extravagantes et pas sur une fenêtre réduite (pas minimisée).
Mais bon, pour le 1er cas, il faut limiter par rapport au max de l'écran moins la TaskBar, c'est du moins comme ça que je l'ai mis sous contrôle.

Edit: 20h25 fichier modifié pour utiliser la correction du post #55 pour simplifier. Le résultat est le même.

 

[patricktoulon]

re
Bonjour Dudu2

Sans toujours comprendre pourquoi un GetWindowRect GetActiveWindow, R sur une fenêtre maximisée donne des valeurs extravagantes et pas sur une fenêtre réduite (pas minimisée).

j'ai tenté de te l'expliquer mais visiblement je n'y suis pas arrivé
c'est un problème avec Windows 7 thème aero ou basic
une image parlant mieux que milles mots

le même userform, le même fichier, le même jour,la même taille,il y a juste le changement de theme entre les deux capture s
et cela s'applique a tout ce que tu vois a l’écran 😉
c'est pour cela que je t'ai parlé de la dwma.dll et de ces api

je regarde ton fichier tout a l'heure je pars en inter dans une demie heure

 

[patricktoulon]

re


pour ton fichier
je comprends toujours pas a quoi sert la fonction RatioOccupationÉcran mais bon


test cela en thème basic et aero et regarde bien ou se place le userform

 

[Dudu2]

La fonction RatioOccupationÉcran est un gadget ajouté qui permet de dire par exemple:
"Afficher le UserForm sur la taille de l'écran mais le réduire à 85% par rapport à cette taille."
Edit: j'ai changé le nom en RatioSurDimensionFinale pour (tenter de) clarifier.

test cela en thème basic et aero et regarde bien ou se place le userform

Je sais bien et constate qu'en Aero les entêtes / cadres sont différents.
N.B. je n'ai pas cette légère différence de position constatée sur tes screenshots
Thème Basic:

Thème Aero:

Mais ça ne justifie en rien que le Left et Top du GetWindowRect GetActiveWindow, r1 soient négatifs sur fenêtre maximisée, et ce dans les 2 modes. Il y a sûrement une raison mais je ne la connais pas. Et ton exemple ne me l'explique pas.

En tous cas, la contre-mesure est simple (voir ci-dessous et avec le fichier joint):
Thème Basic ou Aero:

 

[Dudu2]

je pars en inter dans une demie heure

T'es pompier volontaire ou SNSM ?

 

[patricktoulon]

Bonjour Dudu2
non pas du tout ni l'un ni l'autre

tu es le premier a me dire que aero et basic positionne l'uf au bon endroit avec W7
et il y a eu des centaines de tests effectués sur pc différent et tous sans exeption on le même comportement
tu est en dpi 100 ou 120 ?
là tu viens vraiment de me poser une sacré colle 😉car
ton theme basic n'est pas comme chez tout le monde il est pas comme çà normalement

 

[Dudu2]

Bonjour PatrickToulon,
Je ne sais pas trop quoi te dire. Je ne pense ps avoir fait des extravagances avec ces settings que je ne manipule jamais. A part le fond d'écran que j'ai modifié pour ne pas avoir ce logo Windows coloré au beau milieu de l'écran.

Je suis en dpi 120 puisque mon Points To Pixels est 1,666666667.

 

[Dudu2]

En fait la notion de "correction" n'est pas très judicieuse, il n'y a rien à "corriger".
C'est juste une question de sélection de la partie visible à l'écran qui s'applique à tous les coins du rectangle en toutes circonstances. J'ai corrigé le post #55.

 

[patricktoulon]

re
bonjour Dudu2
ma fois c'est bizarre tu es le premier que je vois avec un thème basic comme ça

c'est quelle version de W7 que tu a premium famille ou integrale
et quelle version de excel