Code de changement de la résolution d'un écran

Voilà donc où nous en sommes

j'emploie le "vous" parce que vous êtes maintenant 2 à être intéressés (notre ami hpfx s'est joint au club)

Ce projet impose une résolution de 800 par 600 et rétablit ensuite.
Vous remarquerez que les choses ne sont pas aussi simples que le laissait penser le lien de référence (voir plus haut, hpfx)
Il prend des précautions (j'espère ne pas en avoir oubliées) pour ne pas faire de bêtises avec un moniteur qui ne le supporterait pas et prévoit (hé hé ! ...) le cas où la machine n'accepterait pas une modification sans redémarrer (pardi...)
Vous le voyez bien ! on ne fait pas mumuse n'importe comment avec n'importe quoi.
L'opération reste brutale. J'ai choisi ici de forcer la main à 800 x 600 car je sais que la plupart des moniteurs supportent cette résolution.
Je vous laisse responsables des "forcings" que vous déciderez avec d'autres résolutions. J'ai pris beaucoup de précautions, mais on ne sait jamais...
Lisez bien les commentaires, ils vous parlent de certains aspects, notamment de certaines incidences avec les paramètres système/couleurs (hé hé !)

Je vous ai "fichu" le tout dans le module de la form, pour que vous ayez tout sous les yeux. A vous, ensuite, de répartir la chose entre Form et module(s) .bas comme vous l'entendrez
Pardonnez mes manières de m'amuser en baptisant les variables (c'est chez moi un jeu)

J'ai par ailleurs traité de manière la plus exhaustive possible les interruptions.
Le cas d'une interruption brutale de l'alimentation fonctionnera sans aucune faille

Le cas d'une interruption par CTRL-ALT-SUP est plus délicat (car réactions différentes selon les versions de Windows) et j'ai donc choisi celle que j'ai choisie.

Simplement : en cas d'interruption brutale par CTRL-ALT-SuP sans restitution de la résolution d'origine, lancez à nouveau l'exe de l'appli. Celle-ci rétablira alors la résolution et se refermera aussitôt, tout simplement.
(il va de soi qu'en la relaçant encore (si tel est finalement votre voeu) elle tournera à nouveau normalement. Comprenez bien : ceci n'arrivera que dans les cas d'interruption brutale sans restitution spontanée (pas dans les cas normaux... j'espère être ainsi bien clair...).

J'ajoute que j'y ai inclus ce qu'il fallait pour "signaler" aux autres applis ouvertes la modification intervenur. Les développeurs les plus avancés sauront s'en servir dans les autres applis qu'ils développent et qui sont susceptibles de tourner en même temps.

Quant au principe du va-et-vient auquel je faisais allusion et que j'ai installé dans ce projet ... je vous le laisse découvrir et analyser (il est amusant).

Ah ! un point très important : ce programme nécessite que vous lanciez l'executable compilé (un lancement depuis le start de l'IDE fonctionnerait, certes, mais ne saurait gérer l'insterruption de l'alimentation, ce que l'exe sait, lui, parfaitement faire).

Le projet ?

Une form et un Label nommé RESENCOURS (non indispensable mais là pour que vous voyiez les choses)

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
Option Explicit
 
'===============================
'--------
Private Const REG_NONE = 0
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = 5
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_RESOURCE_LIST = 8
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10
Private Const REG_QWORD = 11
 
 
 
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006
'--------
 
'==========================
Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const EWX_POWEROFF = 8
 
 
'=========================
 
Const WM_DISPLAYCHANGE = &H7E 'signal de modification de la résolution
Const HWND_BROADCAST = &HFFFF& 'identifiant des fenêtres recevant un "message"
Const CCDEVICENAME = 32 'nom du dispositif
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000 'Bits per pixel
Const DM_PELSWIDTH = &H80000 'Pixel Width
Const DM_PELSHEIGHT = &H100000 'Pixel Height
Const CDS_UPDATEREGISTRY = &H1 ' mise à jour du Registre
Const CDS_TEST = &H4 'test de présence
Const DISP_CHANGE_SUCCESSFUL = 0 'modif résolution réussie
Const DISP_CHANGE_RESTART = 1 ' la modif résolution sera prise en compte après derémarrage
Const BITSPIXEL = 12 'identificateur pour l'extraction du nb de bits per pixel
Private 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 '-------------------------------------------|
'---------------------------------------------------------------------------------------------|
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
 
 
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim MeW As Integer, MeH As Integer, mon_coco As String
Sub ChangeRes(resX As Long, resY As Long, Bits As Long)
    Dim dmecran As DEVMODE, ScInfo As Long, erg As Long, reponse As VbMsgBoxResult
    erg = EnumDisplaySettings(0&, 0&, dmecran) ' on passe les informations à dmecran
    'voilà ce que l'on va changer dans dmecran
    dmecran.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    dmecran.dmPelsWidth = resX 'largeur de l'écran, en pixels
    dmecran.dmPelsHeight = resY 'hauteur de l'écran, en pixels
    dmecran.dmBitsPerPel = Bits 'IMPORTANT : nombre de bits qui pourrait être 8, 16, 24, 32, voire 4
    'A ne pas signaler le nombre de bits, le changement de résolution pourrait cesser de fonctionner si l'on
    'modifie le nombre de couleurs (lui aussi en interactivité avec le nb de bits)!!!
    'Allons-y ! modifions et essayons de surveiller ce qui a pu être fait, hein...
    erg = ChangeDisplaySettings(dmecran, CDS_TEST) 'on lance la fonction en mode test
    'on "regarde" si ça a "marché" et s'il y a des "contraintes supplémentaires" dûes à la machine finale
    Select Case erg&
      Case DISP_CHANGE_RESTART 'la fonction  a fait savoir que les modifs étaient subordonnées à un reboot
        reponse = MsgBox("Il vous faut redémarrer Windows", vbYesNo + vbSystemModal, "Info")
        If reponse = vbYes Then ' lutlisateur fait savoir qu'il est d'accord pour rebooter
          erg& = ExitWindowsEx(EWX_REBOOT, 0&) 'on lance le reboot (fonction ExitWindowsEx option reboot)
        End If
      Case DISP_CHANGE_SUCCESSFUL ' le mode test ayant réussi
        erg = ChangeDisplaySettings(dmecran, CDS_UPDATEREGISTRY) 'on relance la fonction en mode modif du Registre
        ScInfo = resY * 2 ^ 16 + resX
        'on signifie à toutes les fenêtres que la résolution a changé (IMPORTANT)
        SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal Bits, ByVal ScInfo
      Case Else 'le mode test de la fonction a fait savoir que la commande ne pouvait pas réussir
        MsgBox "Désolé mais ce mode n'est pas supporté par votre UC!", vbOKOnly + vbSystemModal, "Echec"
    End Select
End Sub
 
Private Sub Form_Activate()
  Dim resh As Integer, resv As Integer
  mon_coco = App.Path & "\meszozos.txt"
  If Dir(mon_coco) <> "" Then
      Open App.Path & "\meszozos.txt" For Input As #1
        Input #1, resh, resv
      Close #1
      DoEvents
      If Not je_zieute(resh, resv) Then
        'MsgBox resh & "  " & resv
        Dim nDC As Long
        nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&) 'création d'un "DEVICE CONTEXT"
        ChangeRes Val(resh), Val(resv), GetDeviceCaps(nDC, BITSPIXEL)
        DoEvents
        DeleteDC nDC
       End If
       Kill mon_coco
       Unload Me
      Exit Sub
  End If
  resh = Screen.Width \ Screen.TwipsPerPixelX
  resv = Screen.Height \ Screen.TwipsPerPixelY
  Open mon_coco For Output As #1
    Write #1, resh
    Write #1, resv
  Close #1
  MeH = Me.Height: MeW = Me.Width
  RESENCOURS.Caption = resh & " x " & resv
  imposons 800, 600
  SaveString HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce", _
  "WinTray", App.Path & "\" & App.EXEName & ".exe"
End Sub
 
Private Function je_zieute(quoih As Integer, quoiv As Integer) As Boolean
  je_zieute = True
  If quoih <> Screen.Width \ Screen.TwipsPerPixelX Then je_zieute = False
  If quoiv <> Screen.Height \ Screen.TwipsPerPixelY Then je_zieute = False
End Function
 
Private Sub Form_Terminate()
  bachibouzouk
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
   bachibouzouk
End Sub
Private Sub bachibouzouk()
    Dim resh As Long, resv As Long, a As Long
    If Dir(mon_coco) <> "" Then
       Open App.Path & "\meszozos.txt" For Input As #1
         Input #1, resh, resv
       Close #1
       Dim nDC As Long
       nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&) 'création d'un "DEVICE CONTEXT"
       ChangeRes Val(resh), Val(resv), GetDeviceCaps(nDC, BITSPIXEL)
       DoEvents
       DeleteDC nDC
       Kill mon_coco
       a = RegDeleteKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce")
     End If
End Sub
 
Public Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
  Dim ret
  RegCreateKey hKey, strPath, ret 'on crée une nouvelle clé
  RegSetValueEx ret, strValue, 0, REG_SZ, ByVal strData, Len(strData) 'on lui attribue une valeur
  RegCloseKey ret 'et on la ferme
End Sub
 
Private Sub imposons(jedish As Long, jedisv As Long)
  Dim nDC As Long
  nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&) 'création d'un "DEVICE CONTEXT"
  'Appel du changement de résolution - passage des paramètres souhaités
   ChangeRes jedish, jedisv, GetDeviceCaps(nDC, BITSPIXEL)
  DoEvents
  DeleteDC nDC  'effacement (libération mémoire) du "DEVICE CONTEXT" créé par GetDeviceCaps
  '============================================================================
  ' ce qui suit n'est là que pour recentrer la feuille à l'écran
  ' et pour afficher la nouvelle résolution
  With Me:
    .Height = MeH
    .Width = MeW
    .Top = (Screen.Height - Me.Height) / 2
    .Left = (Screen.Width - Me.Width) / 2
  End With
  DoEvents
  'on affiche la résolution en cours
  RESENCOURS.Caption = Screen.Width \ Screen.TwipsPerPixelX & " x " & Screen.Height \ Screen.TwipsPerPixelY
 
 '=============================================================================
End Sub

Précisions : j'ai testé sans faille sous XP et sous Win 2000
Avec Win 2000, toutefois : si la mémoire est pleine à craquer (trop de fenêtres d'applications ouvertes), la machine se plante. J'ai testé aussi le lien, tel qu'il était : se plante également dans les mêmes circonstances.

Voilà ! j'ai en ce qui me concerne fini de faire le tour, sauf à rajouter (peut-être) que le code que l'on trouve dans le lien proposé plus haut n'est pas un code prudent ... et je suggère que quelqu'un se dévoue (pas moi) pour déposer ce qu'il convient de déposer.

A.... plus tard peut-être...je ne sais quand ...