In too many cases I had problems with screen resolution in my work with users. Their tables were too wide or too short or the colors were of bad quality. So to resolve that problem I made a short class that will force users to use proper screen resolution and color depth when he or she uses the application. After the work is done, screen resolution will be reset to its previous value. I like to use this class in database scripts (initialize call constructor and adopt my screen settings and terminate call destructor).
'Script Library Option Public Option Explicit Type DevMode 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 dmLogPixels As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long dmICMMethod As Long dmICMIntent As Long dmMediaType As Long dmDitherType As Long dmICCManufacturer As Long dmICCModel As Long dmPanningWidth As Long dmPanningHeight As Long End Type Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As DevMode, Byval dwFlags As Long) As Long Declare Function GetSystemMetrics Lib "user32.dll" (Byval nIndex As Long) As Long Declare Function GetDeviceCaps Lib "gdi32" (Byval hdc As Long, Byval nIndex As Long) As Long Declare Function GetDesktopWindow Lib "user32" () As Long Declare Function GetDC Lib "user32" (Byval hwnd As Long) As Long Declare Function ReleaseDC Lib "user32" (Byval hwnd As Long, Byval hdc As Long) As Long Const CDS_UPDATEREGISTRY = 1 Const DM_BITSPERPEL = &H40000 Const DM_PELSHEIGHT = &H100000 Const DM_PELSWIDTH = &H80000 Const SM_CXSCREEN = 0 Const SM_CYSCREEN = 1 Const BITSPIXEL = 12 %REM dmBitsPerPel 1 bpp Monochrome 4 bpp 16 colors 8 bpp 256 colors 15 bpp 32,768 (32K) colors 16 bpp 65,536 (64K) colors 24 bpp 16.7 million (16.7M) colors 32 bpp 16.7 million colors %END REM %REM ScreenResolution X * Y 640 * 480 800 * 600 1024 * 768 1152 * 864 1280 * 960 1280 * 1024 %END REM Class WindowResolution Private mPreviouseWidth As Long Private mPreviouseHeight As Long Private mCurrentWidth As Long Private mCurrentHeight As Long Private mPreviouseBPP As Long Private mCurrentBPP As Long Sub new() 'constructor Dim hSrcDC As Long 'Get screen width mPreviouseWidth = GetSystemMetrics (SM_CXSCREEN) mCurrentWidth = mPreviouseWidth 'Get screen hight mPreviouseHeight = GetSystemMetrics (SM_CYSCREEN) mCurrentHeight = mPreviouseHeight 'Get bits per pixel hSrcDC = GetDC(GetDesktopWindow()) mPreviouseBPP = GetDeviceCaps (hSrcDC, BITSPIXEL) ReleaseDC GetDesktopWindow(), hSrcDC mCurrentBPP = mPreviouseBPP End Sub Property Get ScreenWidth As Long 'Read only ScreenWidth = mCurrentWidth End Property Property Get ScreenHeight As Long 'read only ScreenHeight = mCurrentHeight End Property Property Get BitsPerPixel As Long 'Read only BitsPerPixel = mCurrentBPP End Property Sub ChangeResolution(lWidth As Long, lHeight As Long, lBpp As Long) 'method 'lBpp means long BitPerPixel Dim myDevMode As DevMode Dim lRes As Long 'Setting usful parameters myDevMode.dmSize = Len(myDevMode) myDevMode.dmPelsWidth = lWidth myDevMode.dmPelsHeight = lHeight myDevMode.dmBitsPerPel = lBpp myDevMode.dmFields = DM_BITSPERPEL Or DM_PELSHEIGHT Or DM_PELSWIDTH lRes = ChangeDisplaySettings(myDevMode, CDS_UPDATEREGISTRY) 'Change screen resolution using win API If lRes = 0 Then 'For successfull operation change class members mCurrentWidth = lWidth mCurrentHeight = lHeight mCurrentBPP = lBpp End If End Sub Sub delete() 'destructor ChangeResolution mPreviouseWidth, mPreviouseHeight, mPreviouseBPP End Sub End Class 'Database Script Option Explicit Use "WindowResolution" Dim win As WindowResolution Sub Initialize Set win = New WindowResolution win.ChangeResolution 800, 600, 32 End Sub Sub Terminate Set win = Nothing End Sub
This was first published in March 2003