Proper screen resolution

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 DM_BITSPERPEL = &H40000
Const DM_PELSHEIGHT = &H100000
Const DM_PELSWIDTH = &H80000
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 
%REM ScreenResolution
X   *  Y
640  *  480
800  *  600
1024  *  768
1152  *  864
1280  *  960
1280  *  1024

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
  mCurrentWidth = mPreviouseWidth
  'Get screen hight
  mPreviouseHeight = GetSystemMetrics
  mCurrentHeight  = mPreviouseHeight
  'Get bits per pixel
  hSrcDC = GetDC(GetDesktopWindow())
  mPreviouseBPP =  GetDeviceCaps
  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 
  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

There are Comments. Add yours.

TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.