Type TDEVMODE
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
Private Declare Function EnumDisplaySettingsA Lib "User32" _
(ByVal lpszDeviceName As String, ByVal iModeNum As Long, _
lpDevMode As TDEVMODE) As Long
Private Declare Function ChangeDisplaySettingsA Lib "User32" _
(lpDevMode As TDEVMODE, ByVal dwflags As Long) As Long
Private Declare Function GetDC Lib "User32" _
(ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "User32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function ExitWindowsEx Lib "User32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
'____________________________________________________________
Private Sub LireRes(Optional HorzPix, Optional VertPix, _
Optional BitsPerPel)
Dim DC As Long
DC = GetDC(0)
HorzPix = GetDeviceCaps(DC, 8)
VertPix = GetDeviceCaps(DC, 10)
BitsPerPel = GetDeviceCaps(DC, 12)
ReleaseDC 0, DC
End Sub
'____________________________________________________________
Private Function ChangeRes(Optional HorzPix, _
Optional BitsPerPel) As Integer
Dim DevMode As TDEVMODE, I As Long
Dim ActBitsPerPel As Integer, ActHorzPix As Integer
LireRes ActHorzPix, , ActBitsPerPel
If IsMissing(HorzPix) Then HorzPix = ActHorzPix
If IsMissing(BitsPerPel) Then BitsPerPel = ActBitsPerPel
If HorzPix = ActHorzPix And BitsPerPel = ActBitsPerPel _
Then Exit Function
Do
If EnumDisplaySettingsA(vbNullString, I, DevMode) = 0 _
Then ChangeRes = -2: Exit Function
I = I + 1
Loop Until DevMode.dmPelsWidth = HorzPix _
And DevMode.dmBitsPerPel = BitsPerPel
ChangeRes = ChangeDisplaySettingsA(DevMode, 0)
If ChangeRes = 1 Then ChangeRes = ChangeDisplaySettingsA(DevMode, 1)
If ChangeRes >= 0 Then ChangeRes = ChangeRes + 1
End Function
'____________________________________________________________
Sub ChangerRésolution()
' Tente de passer en résolution 800 x 600 et 65 536 couleurs
Dim Rep As Long
Select Case ChangeRes(800, 16) ' (65 536 = 2^16)
Case 0
MsgBox "Aucun changement de résolution nécessaire."
Case 1
MsgBox "Résolution modifiée."
Case 2
Rep = MsgBox("Vous devez redémarrer votre ordinateur " _
& "pour que les changements prennent effet." & vbLf$ & _
"Voulez-vous redémarrer maintenant ?", vbYesNo + vbInformation)
If Rep = vbYes Then ExitWindowsEx 2, 0
Case -1
MsgBox "Impossible de changer de résolution."
Case -2
MsgBox "Résolution et / ou nombre de couleurs non supporté."
End Select
End Sub