Affichage sur écran de résolution différente

**retraite83** · 24/08/2022, 12h06

Bonjour,

L'affichage des feuilles de mon application se fait parfaitement sur des écrans 1920 X 1080

Des utilisateurs ont maintenant des écrans 2880 X 1800 en écran externe sous Windows 11

Je sais détecter la largeur et la hauteur de l'écran par cette fonction

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Declare PtrSafe Function GetSystemMetrics32 Lib "User32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
 
Public Function Largeur()
    On Error GoTo fin
    Largeur = GetSystemMetrics32(0) ' en pixels
fin:
End Function
 
Public Function Hauteur()
    On Error GoTo fin
    Hauteur = GetSystemMetrics32(1) ' en pixels
fin:
End Function

Ensuite adapter les feuilles par

Code :

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

1
2
3
4
5
6
7
8
Sub Zoom()
 
Select Case Largeur
    Case 1920: ActiveWindow.Zoom = 100
    Case Else: ActiveWindow.Zoom = 72
End Select
 
End Sub

Le problème est que les 2 résolutions d'écran 1920 X 1080 et 2880 X 1800 ne sont pas proportionnelles

Du coup on profite pas de la largeur de l'écran en 2880, la fonction "Zoom" gardant les proportions

Peut-on afficher les feuilles en adaptant à la fois la largeur ET la hauteur.

Merci

**laurent_ott** · 24/08/2022, 12h57

Bonjour,
Une idée qui me vient, pourquoi ne pas forcer la résolution de l'écran en 1920x1080 quand l'utilisateur lance votre application, puis lui restituer sa résolution quand il en sort ?

Code VBA :

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
'------------------------------------------------------------------------------------------------
Public Function ChangeScreen_Resolution(ScrWidth As Long, ScrHeight As Long) As Boolean
'------------------------------------------------------------------------------------------------
' Mémorise la résolution avant de la changer:
If Anc_ScrWidth = 0 Then Anc_ScrWidth = GetSystemMetrics(0)
If Anc_ScrHeight = 0 Then Anc_ScrHeight = GetSystemMetrics(1)
 
' Si pas de valeur indiquée dans les arguments alors restaure la résolution d'origine:
If ScrWidth + ScrHeight = 0 Then
    ScrWidth = Anc_ScrWidth
    ScrHeight = Anc_ScrHeight
End If
 
' Si la résolution demandée est déjà celle existante alors rien a faire et quitte:
If ScrWidth = GetSystemMetrics(0) And ScrHeight = GetSystemMetrics(1) Then ChangeScreen_Resolution = True: Exit Function
 
' Mémorise dans TypDevM la configuration de l'écran en utilisant la structure TypDevMODE:
Dim TypDevM As TypDevMODE
Call EnumDisplaySettings(0, 0, TypDevM)
 
' Change les valeurs de TypDevM:
TypDevM.dmFields = &H80000 Or &H100000
TypDevM.dmPelsWidth = ScrWidth
TypDevM.dmPelsHeight = ScrHeight
 
' Change la résolution en passant en argument TypDevM:
If ChangeDisplaySettings(TypDevM, &H4) = 0 Then ChangeScreen_Resolution = True
 
End Function

avec :

Code VBA :

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
Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
 
' Pour la résolution de l'écran (http://www.mrexcel.com/archive/VBA/29971.html):
Public Type TypDevMODE
    dmDeviceName As String * 32
    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 * 32
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

**retraite83** · 24/08/2022, 13h14

Merci

je vais essayer

**retraite83** · 24/08/2022, 13h56

Rebonjour,

malheureusement ce code est au dessus de ma compréhension

**laurent_ott** · 24/08/2022, 14h41

Bonjour,
Le code compatible 32 et 64 bits.

Lancez la fonction Test où vous aurez indiqué en ligne 47 la résolution désirée :

Code VBA :

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
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Private Declare PtrSafe Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
 
 
' Pour la résolution de l'écran (http://www.mrexcel.com/archive/VBA/29971.html):
Public Type TypDevMODE
    dmDeviceName As String * 32
    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 * 32
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
 
Public Anc_ScrWidth As Long
Public Anc_ScrHeight As Long
 
 
'------------------------------------------------------------------------------------------------
Public Sub Test()
'------------------------------------------------------------------------------------------------
' Mémorise la résolution actuelle:
Call ChangeScreen_Resolution(0, 0)
 
' Change la résolution, par exemple 640x480 ou comme ici 1920x1080 (rien ne se passe si la résolution est déjà celle demandée):
Call ChangeScreen_Resolution(1920, 1080)
 
' Message:
MsgBox "Nouvelle résolution..."
 
' Restaure la résolution graphique d'origine:
Call ChangeScreen_Resolution(0, 0)
 
End Sub
'------------------------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------------------------
Public Function ChangeScreen_Resolution(ScrWidth As Long, ScrHeight As Long) As Boolean
'------------------------------------------------------------------------------------------------
' Mémorise la résolution avant de la changer:
If Anc_ScrWidth = 0 Then Anc_ScrWidth = GetSystemMetrics(0)
If Anc_ScrHeight = 0 Then Anc_ScrHeight = GetSystemMetrics(1)
 
' Si pas de valeur indiquée dans les arguments alors restaure la résolution d'origine:
If ScrWidth + ScrHeight = 0 Then
    ScrWidth = Anc_ScrWidth
    ScrHeight = Anc_ScrHeight
End If
 
' Si la résolution demandée est déjà celle existante alors rien a faire et quitte:
If ScrWidth = GetSystemMetrics(0) And ScrHeight = GetSystemMetrics(1) Then _
    ChangeScreen_Resolution = True: Exit Function
 
' Mémorise dans TypDevM la configuration de l'écran en utilisant la structure TypDevMODE:
Dim TypDevM As TypDevMODE
Call EnumDisplaySettings(0, 0, TypDevM)
 
' Change les valeurs de TypDevM:
TypDevM.dmFields = &H80000 Or &H100000
TypDevM.dmPelsWidth = ScrWidth
TypDevM.dmPelsHeight = ScrHeight
 
' Change la résolution en passant en argument TypDevM:
If ChangeDisplaySettings(TypDevM, &H4) = 0 Then ChangeScreen_Resolution = True
End Function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------

Bonne programmation.

**retraite83** · 24/08/2022, 14h53

Je vais tenter

en fait j'ai inclus ces lignes sans comprendre à l'open d'un de mes fichiers et en lançant sur un écran 1920 X 1080 j'ai uniquement le message :

MsgBox "Nouvelle résolution..."

je ne vois pas ce qui s'est passé

Affichage sur écran de résolution différente [XL-365]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager