[source]2 variantes pour connaitre la resolution de l'ecran [Sources]

**patricktoulon** · 02/07/2010, 17h48

bonjour a tous

il est parfois necessaire de connaitre la resolution de l'ecran afin de parametrer l'affichage
de divers controls et userforms dans un fichier excel
il existe diverses facons d 'y arriver l'une d'entre elles est de faire apel a l'api "user32" qui fonctionne parfaitement bien
cela dit quand on regarde la longueur du code on peut se dire que finalement
il en faut beaucoup pour faire pas grand chose
ayant pour but de reduire au maximum le code dans mes fichiers
je vous en propose un autre c'est "l'exemple 2 "(7 lignes en tout et pour tout)qui lui fait apel a l'user32 pour le 'desktop(ecran)" puisque getdc(0)=desktop
et l'api gdi32 pour les dimention par les deux variables inscrites dans la "gdi32dll" (8& et 10&) ensuite la formule dans la macro est d'une simplicité deconcertante

voici l'exemple 1 que l'on trouve dans divers endroits (FAQ,SOURCES,CONTRIBUTION) qui vous serez daccors avec moi
est un peu lourd pour avoir 2 nombres et voir meme un peu compliqué a comprendre vu tout les parametre qu'il faut prendre en compte

mettez le code dans un module standard

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
 
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
 
Const ENUM_CURRENT_SETTINGS As Long = -1&
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Public Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
 
End Type
Public DevM As DEVMODE, mesg As String
Public HauteurEcran, LargeurEcran As Long
 
 
Sub Resolution_Ecran()
Call EnumDisplaySettings(0&, ENUM_CURRENT_SETTINGS, DevM)
 
LargeurEcran = DevM.dmPelsWidth
HauteurEcran = DevM.dmPelsHeight
MsgBox LargeurEcran & "X" & HauteurEcran & "pixels"
End Sub

et voici l'exemple 2 qui vous le conviendrez et largement plus simple et comprehensible
mettez le code dans un module standard

Code :

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

1
2
3
4
5
6
7
8
9
10
 
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd&) As Long
Public Declare Function DIMENTION Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC&, ByVal nIndex&) As Long
Public HauteurEcran, LargeurEcran As Long
 
Sub Resolution_Ecran()
LargeurEcran = DIMENTION(GetDC(0), 8&)   ' DONNE la largeur de l'écran en pixels
HauteurEcran = DIMENTION(GetDC(0), 10&)  ' DONNE la  hauteur de l'écran en pixels
MsgBox LargeurEcran & "X" & HauteurEcran & "pixels"
End Sub

exemple d'utilisation: a metre dans le module de l'userform

Code :

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

1
2
3
4
5
 
Private Sub UserForm_Initialize()
me.width=largeurecran*0.75
me.height=hauteurecran*0.75
End Sub

le "*0.75" c'est pour convertir l'unité de mesure "pixel" en unité de mesure "point" pour excel car 1 pixel est = a 0.75 point

voila si ca peut servir

au plaisir .....

**patricktoulon** · 05/01/2011, 15h08

et en voila une troisième
donné par fring dans une discution
dans celle ci on utilise que l'api de la user32.dll

Code :

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

1
2
3
4
5
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
Sub AfficherResolution()
MsgBox "La résolution de votre écran est de " & Chr(13) & GetSystemMetrics(0) & "   de largeur par " & Chr(13) & GetSystemMetrics(1) & "   de hauteur"
End Sub

**Montor** · 19/02/2011, 20h34

Mea culpa

voici ma contribution

Code :

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

1
2
3
4
5
6
7
8
9
10
Option Explicit
Private Type Rect
 Left As Long
 Top  As Long
 Right As Long
 Bottom As Long
End Type
 
Private Declare Function GetDesktopWindow Lib "User32.dll" () As Long
Private Declare Function GetWindowRect Lib "User32.dll" (ByVal Hwnd As Long, R As Rect) As Long

test

Code :

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

1
2
3
4
5
Private Sub CommandButton1_Click()
Dim d As Rect
  GetWindowRect GetDesktopWindow, d
  MsgBox d.Right & vbNewLine & d.Bottom
End Sub

**patricktoulon** · 20/02/2011, 14h05

bonjour montor

oui effectivement utiliser un rectangle sur la base du desktop est une tres bonne idée

mais il me semble que tu avait parlé de getdevicecaps (gdi32) et là tu utilise la user32 dll

et bien qu'elle soit parfaitement fonctionnelle ta methode utilise deux fonction de cette dll et la mienne en utilise qu'une seule
j'aurait bien aimer voir un exemple avec la gdi32.dll

au plaisir de te lire

**Montor** · 20/02/2011, 21h00

désolé je pensais a ton 2me exemple cité au dessus...

Envoyé par Montor

Mea culpa

**patricktoulon** · 21/02/2011, 12h04

bonjour montor

je me disait bien aussi
quelle version pourrait _il me sortir avec "getdevicecaps" autre que la mienne

et bien figure toi que je suis en train de melanger la tienne et la mienne

enfin cela dit je pense que maintenant personne ne pourra dire qu'il ne sait pas comment faire

je finalise et je depose

au plaisir

**patricktoulon** · 11/06/2011, 18h45

bonjour a tous

et en voila une quatrième
ici on utilise la localisation du curseur dans le rectangle

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Declare Function GetClipCursor Lib "user32" (lprc As rect) As Long
Type rect
      Left As Long
      Top As Long
      Right As Long
      Bottom As Long
End Type
Dim ecran As rect
 
Sub taille_écran()
 Call GetClipCursor(ecran)
MsgBox ecran.Right - ecran.Left & " x " & ecran.Bottom - ecran.Top
End Sub

au plaisir

**patricktoulon** · 23/08/2015, 13h34

et en voila une 5 eme et 6 eme
en effet les apis c'est bien mais depuis 64 pour certains c'est la croix et la baniere pour les faire fonctionner
et bien cette fois si allons chercher la resolution de l'écran dans la base de registre

1 er soultion (plus facile !!!!exporter la clé dans un fichier texte pour chercher le resultat a l'interieur )

Code :

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

1
2
3
4
5
Sub test()
cle = "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Hardware Profiles\0001\System\CurrentControlSet\Control\VIDEO\"
chemin = ThisWorkbook.Path & "\cle.txt"
lit_reg cle, chemin
End Sub

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
Function lit_reg(cle, chemin)
Set fs = CreateObject("Scripting.FileSystemObject")
Set sh = CreateObject("WScript.Shell")
'export dev la clé (les guillements évitent les pb avec les adresses completes)
sh.Run "%comspec% /c REGEDIT /E """ & chemin & """ """ & cle & """", 0, True
'attendre que le fichier reg soit créé
Do: ok = Dir(chemin): Loop While ok = ""
'le deuxième argument booleen (true) pour lire en ANSI, dépend de la version de regedit !
Set fich = fs.OpenTextFile(chemin, 1, False, True)
texte = fich.readall 'texte récupere le contenu du fichier
fich.Close
' recherche de la valeur
ligne = Split(texte, vbCrLf)
 largeur = "": hauteur = ""
 For i = 0 To UBound(ligne)
If InStr(ligne(i), "DefaultSettings.XResolution") Then largeur = Val("&H" & Split(ligne(i), ":")(1))
If InStr(ligne(i), "DefaultSettings.YResolution") Then hauteur = Val("&H" & Split(ligne(i), ":")(1))
If largeur <> "" And hauteur <> "" Then Exit For
Next
MsgBox "Résolution de l'écran : " & largeur & "/" & hauteur
Kill chemin
End Function

somme toute c'est pas tres compliqué il suffit de convertir en long la valeur hexadecimale des deux valeur DWord X et Y resolution cela se passe dans les lignes 16 et 17
il semblerait que pour le moment sauf vos contre-dires que cela soit valable pour toutes les versions de windows

2 eme solution (moins facile a comprendre car on entre dans une boucle récursive sans créer de fichier texte )

Code :

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

1
2
3
4
5
6
Sub TEST_H_KEY_LOCAL_MACHINE_ALLVERSION()     ' WINDOWS 7;WINDOWS 10
    Dim CheminCle As String, cherche As String, obool As Boolean
    obool = True: cherche = "0000"
    CheminCle = "SYSTEM\CurrentControlSet\Hardware Profiles\UnitedVideo\CONTROL\VIDEO"
    cherchecle &H80000002, CheminCle, "", cherche, obool
End Sub

fonction

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
Function cherchecle(base, CheminCle, savesouscle, cherche, obool)
    Dim BDR, soucle, soucles
    Set BDR = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    BDR.EnumKey base, CheminCle, souscles
    If Not IsNull(souscles) And obool Then
        If savesouscle <> cherche Then
            For Each souscle In souscles
                cherchecle base, CheminCle & "\" & souscle, souscle, cherche, obool
            Next
        Else
            lire (CheminCle & "\" & souscle), base
            obool = False
        End If
    Else
        If savesouscle = cherche Then: lire (CheminCle & "\" & souscle), base: obool = False
    End If
End Function

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub lire(cle, base)
    Select Case Right(Hex(base), 1)
    Case 0: baselettre = "HKEY_CLASSES_ROOT": Case 1: baselettre = "HKEY_CURRENT_USER": Case 2: baselettre = "HKEY_LOCAL_MACHINE"
    Case 3: baselettre = "HKEY_USERS": Case 5: baselettre = "HKEY_CURRENT_CONFIG"
    End Select
    Set sh = CreateObject("WScript.Shell")
    largeur = sh.regread(baselettre & "\" & cle & "\DefaultSettings.XResolution")
    hauteur = sh.regread(baselettre & "\" & cle & "\DefaultSettings.YResolution")
    MsgBox "resolution de l'ecran : " & largeur & " / " & hauteur
End Sub

veuillez noter que j'ai séparer la lecture de la recherche de la clé afin de me servir de cette fonction pour d'autre recherche de clé

Pourquoi une recherche récursive me direz vous
et bien parce que la cle parent de la cle"0000" du style "{EFBCYEC3-44CB-47S2-87C6-1DE3B7EAFAE1} "qui contient les données peut varier dun os a l'autre voir d'un PC a l'autre
donc se qui est sur c'est la cle"0000" le reste doit etre récursif

remerciment aKimy.fr pour m'avoir bien aider sur la récursivité

voila a plus

**surgeon84fr** · 09/02/2017, 19h35

Bonsoir

je viens de trouver ce sujet lié à cet autre (https://www.developpez.net/forums/d1...ment-userform/).
J'ai cru que je pourrai comprendre seul mais non....pas assez expérimenté.

J'utilise une "function" pour la création à la volée d'un userform. Cela fonctionne très bien.

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
Option Explicit
 
'Passed back to the function from the UserForm
Public GETOPTION_RET_VAL As Variant
 
Function GetOption(OpArray, Default, Title)
    Dim TempForm  'As VBComponent
    Dim NewOptionButton As Msforms.OptionButton
    Dim NewCommandButton1 As Msforms.CommandButton
    Dim NewCommandButton2 As Msforms.CommandButton
    Dim TextLocation As Integer
    Dim x As Integer, i As Integer, TopPos As Integer
    Dim MaxWidth As Long
    Dim WasVisible As Boolean
 
'   Hide VBE window to prevent screen flashing
    'Application.VBE.MainWindow.Visible = False
 
'   Create the UserForm
    Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3)
    TempForm.Properties("Width") = 800
 
'   Add the OptionButtons
    TopPos = 4
    MaxWidth = 0 'Stores width of widest OptionButton
    For i = LBound(OpArray) To UBound(OpArray)
        Set NewOptionButton = TempForm.Designer.Controls.Add("forms.OptionButton.1")
        With NewOptionButton
            .Width = 800
            .Caption = OpArray(i)
            .Height = 15
            .Left = 8
            .Top = TopPos
            .Tag = i
            .AutoSize = True
            If Default = i Then .Value = True
            If .Width > MaxWidth Then MaxWidth = .Width
        End With
        TopPos = TopPos + 15
    Next i
 
'   Add the Cancel button
    Set NewCommandButton1 = TempForm.Designer.Controls.Add("forms.CommandButton.1")
    With NewCommandButton1
        .Caption = "Annuler"
        .Height = 18
        .Width = 44
        .Left = MaxWidth + 10
        .Top = 2
    End With
 
'   Add the OK button
    Set NewCommandButton2 = TempForm.Designer.Controls.Add("forms.CommandButton.1")
    With NewCommandButton2
        .Caption = "OK"
        .Height = 18
        .Width = 44
        .Left = MaxWidth + 10
        .Top = 20
        .Default = True
    End With
 
'   Add event-hander subs for the CommandButtons
    With TempForm.CodeModule
        x = .CountOfLines
        .InsertLines x + 1, "Sub CommandButton1_Click()"
        .InsertLines x + 2, "  GETOPTION_RET_VAL=False"
        .InsertLines x + 3, "  Application.StatusBar = """""
        .InsertLines x + 4, "  Unload Me"
        .InsertLines x + 5, "End Sub"
 
        .InsertLines x + 6, "Sub CommandButton2_Click()"
        .InsertLines x + 7, "  Dim ctl"
        .InsertLines x + 8, "  GETOPTION_RET_VAL = False"
        .InsertLines x + 9, "  For Each ctl In Me.Controls"
        .InsertLines x + 10, "    If ctl.Tag <> """" Then If ctl Then GETOPTION_RET_VAL = ctl.Tag"
        .InsertLines x + 11, "  Next ctl"
        .InsertLines x + 12, "  Unload Me"
        .InsertLines x + 13, "End Sub"
    End With
 
'   Adjust the form
    With TempForm
        .Properties("Caption") = Title
        .Properties("Width") = NewCommandButton1.Left + NewCommandButton1.Width + 20
        If .Properties("Width") < 160 Then
            .Properties("Width") = 160
            NewCommandButton1.Left = 106
            NewCommandButton2.Left = 106
        End If
        .Properties("Height") = TopPos + 30
        If .Properties("Height") < 50 Then
            .Properties("Height") = 60
        End If
    End With
 
'   Show the form
    VBA.UserForms.Add(TempForm.Name).Show
 
'   Delete the form
    ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm
 
'   Pass the selected option back to the calling procedure
    GetOption = GETOPTION_RET_VAL
End Function

Mon souci est la gestion du double écran et l'affichage de tous les userform sur le mauvais écran.
J'utilise un portable avec une station d'accueil et mon écran principal se trouve être l'écran 2.(mon écran 2, face à moi, est à gauche de mon écran 1)

Mon fichier excel est donc ouvert sur le 2 mais tous les userform se lancent sur le 1 (en plus, collés à la paroi gauche du 1).

Je me disais pouvoir exploiter votre "function" pour afficher mes userform sur le même écran où est ouvert mon fichier excel (le 2) mais je n'y arrive pas.

Pourriez-vous m'aider à modifier ou rajouter ce qu'il me manque pour y arriver? A savoir qu'il se peut que j'utilise mon fichier sur d'autres PC qui n'ont peut-être qu'un écran ou bien 2 mais inversés dans leur position par rapport à la mienne.

En vous remerciant infiniment par avance.

cdlt

Eric

**patricktoulon** · 11/02/2017, 11h52

Bonjour
je ne crois pas que ce soit possible en VBA ca fait partie de la gestion des pin de broche de tes prise VGA HDMI DVI
a moins que tu fonctionne en bureau étendu et jouer avec les left/top je vois pas trop

**mjpmjp** · 11/05/2017, 15h30

bonjour,
j'ai ouvert le fichier sur un ecran 24" et j'ai déplacé le form sur l'écran 32" à droite
pour ce faire dans les propriétés du form :
StartUpPosition = 0 - Manual
Left = 2500

@+JP

**patricktoulon** · 11/05/2017, 15h49

Envoyé par mjpmjp

bonjour,
j'ai ouvert le fichier sur un ecran 24" et j'ai déplacé le form sur l'écran 32" à droite
pour ce faire dans les propriétés du form :
StartUpPosition = 0 - Manual
Left = 2500

@+JP

bonjour mjpmjp le problème c'est que ton 2500 est arbitraire tout le monde n'a pas la même résolution
d'autant plus que en aucun cas l'utilisation de l'écran 1 ou 2 est détecté
bref c'est du bricolage
après recherche il me semble que getsystemmetrics(argument) peut te donner l'ecran maitre mais je n'en suis pas sur
difficile de trouver de la doc sur ce point getsystemmetrics etant le plus souvent utilisé avec les argument 1 et 2 pour la resolution
des que je trouve je partage