-
Resolution change issues
I'm making some resolution changing tests. My target is to temporarily change the resolution (ie. not change registry settings) and then restore the original resolution once the application completes. Thus I made this formless test project:
Code:
Option Explicit
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
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 * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const CDS_FULLSCREEN = &H4
Private Const CDS_TEST = &H2
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Function ChangeResolution(ByVal NewWidth As Long, ByVal NewHeight As Long) As Boolean
Dim DevM As DEVMODE
EnumDisplaySettings 0, 0, DevM
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth = NewWidth
DevM.dmPelsHeight = NewHeight
If ChangeDisplaySettings(DevM, CDS_TEST) = DISP_CHANGE_SUCCESSFUL Then
ChangeResolution = (ChangeDisplaySettings(DevM, CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL)
If ChangeResolution Then
SendMessage &HFFFF&, &H7E, DevM.dmBitsPerPel, ByVal (NewWidth And &HFFFF&) Or ((NewHeight And &H7FFF&) * &H10000)
End If
End If
End Function
Sub Main()
Dim lngWidth As Long, lngHeight As Long
lngWidth = Screen.Width \ Screen.TwipsPerPixelX
lngHeight = Screen.Height \ Screen.TwipsPerPixelY
If ChangeResolution(640, 480) Then
MsgBox lngWidth & " x " & lngHeight
ChangeResolution lngWidth, lngHeight
End If
End Sub
The first run is alright. However, when I get as far as the second run suddenly lngWidth is the same as lngHeight and restoring the original resolution does not work. I have to use Display Settings window to get back.
So: how do I overcome this problem? Why width is suddenly the same as height? Surely some setting somewhere gets messed up, maybe because of an incorrect way to change resolution.
Also: what are the correct values for CDS_FULLSCREEN and CDS_TEST, because I see CDS_TEST with values 2 and 4, but CDS_FULLSCREEN with only 4? But they can't be the same, so somehow these two values have gotten mixed up with people, but unfortunatenaly I don't see any difference in behavior of the code.