Affichage sur écran de résolution différente

Version imprimable

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:

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:

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

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:

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:

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

24/08/2022, 13h14
retraite83

Merci

je vais essayer
24/08/2022, 13h56
retraite83

Rebonjour,

malheureusement ce code est au dessus de ma compréhension

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:

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.

24/08/2022, 14h53
retraite83

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 :

Citation:

MsgBox "Nouvelle résolution..."

je ne vois pas ce qui s'est passé
24/08/2022, 14h58
laurent_ott

Si vous étiez déjà dans résolution demandée il ne se passe rien, c'est indiqué dans le code qu'il est souhaitable de lire.
Modifiez la ligne 47 en mettant les valeurs 640 * 480 et faites un nouveau test.
24/08/2022, 16h01
retraite83

Oui ça marche bien,

je ne vais pas chercher à comprendre plus, je vais simplement mettre le code dans un module

merci bcp, impossible tout seul cela.