Obtain Current and Maximum Screen Display and Color Resolution

Category:

Screen/Graphics

Type:

Classes

Difficulty:

Intermediate

Author:

Chong Long Choo

Version Compatibility:

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Option Explicit ' Name: Obtain Current and Maximum Screen Resolution ' Author: Chong Long Choo ' Email: chonglongchoo@hotmail.com ' Date: 12 September 1999 '<--------------------------Disclaimer-------------------------> ' 'This sample is free. You can use the sample in any form. 'Use this sample at your own risk! I have no warranty 'for this sample. 'How to use '--------------------------------------------------------------- ' Dim objScrRes As clsScrRes ' ' Set objScrRes = New clsScrRes ' Debug.Print objScrRes.AvailableDisplayModes ' Debug.Print objScrRes.MaxHRes ' Debug.Print objScrRes.MaxVRes ' Debug.Print objScrRes.MaxColorResolution ' Debug.Print objScrRes.MaxColorResolutionString ' Debug.Print objScrRes.CurrentColorResolution(Me) ' Debug.Print objScrRes.CurrentColorResolutionString(Me) ' Debug.Print objScrRes.CurrentHRes(Me) ' Debug.Print objScrRes.CurrentVRes(Me) Private Declare Function EnumDisplaySettings Lib "user32" _ Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, _ ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc _ As Long, ByVal nIndex As Long) As Long Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90 Private Const BITSPIXEL As Long = 12 Private Const HORZRES As Long = 8 Private Const VERTRES As Long = 10 Private Const CCDEVICENAME As Long = 32 Private Const CCFORMNAME As Long = 32 Private Const DM_BITSPERPEL As Long = &H40000 Private Const DM_PELSWIDTH As Long = &H80000 Private Const DM_PELSHEIGHT As Long = &H100000 Private Const DM_DISPLAYFLAGS As Long = &H200000 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 AvailScrRes() As DEVMODE Private piAvailableDisplayModes As Integer

Code:

Public Property Get MaxColorResolution() As Integer
    'Returns Highest Screen Color Resolution in number of bits
    Dim iAns As Integer
    Dim iTest As Integer
    
    Dim iCtr As Integer
    For iCtr = 0 To piAvailableDisplayModes - 1
        iTest = AvailScrRes(iCtr).dmBitsPerPel
        If iTest > iAns Then iAns = iTest
    Next

MaxColorResolution = iAns

End Property

Public Property Get MaxColorResolutionString() As String
    Dim i As Integer
    Dim sAns As String
    
    'Returns Highest Possible Color Resolution
    'as one of the strings below
    i = MaxColorResolution
    Select Case i
    Case 4
        sAns = "16 Color"
    Case 8
        sAns = "256 Color"
    Case 16
        sAns = "High Color"
    Case 24, 32
        sAns = "True Color"
        
    End Select
    
     MaxColorResolutionString = sAns
End Property

Public Property Get MaxHRes() As Long
    'Returns Maximum Pixel Width allowed on system
    '(e.g., if 1024 X 768 is highest screen resolution allowed,
    'returns 1024)
    Dim iAns As Integer
    Dim iTest As Integer
    Dim iCtr As Integer

For iCtr = 0 To piAvailableDisplayModes - 1
        iTest = AvailScrRes(iCtr).dmPelsWidth
        If iTest > iAns Then iAns = iTest
    Next
    MaxHRes = iAns
End Property

Public Property Get MaxVRes() As Long
    'Returns Maximum Pixel Height allowed on system
    '(e.g., if 1024 X 768 is highest screen resolution allowed,
    'returns 768)
    Dim iAns As Integer
    Dim iTest As Integer
    
    Dim iCtr As Integer
    For iCtr = 0 To piAvailableDisplayModes - 1
        iTest = AvailScrRes(iCtr).dmPelsHeight
        If iTest > iAns Then iAns = iTest
    Next
    
    MaxVRes = iAns
End Property

Public Property Get AvailableDisplayModes() As Integer

'Returns Number Of Valid Display Modes on the system
    'Examples of valid diplay modes are 800 X 600, High Color
    '640 X 480, True Color, etc.
    AvailableDisplayModes = piAvailableDisplayModes
End Property

Public Function CurrentHRes(objForm As Object) As Long
     'returns current Horizontal Resolution in Pixels
    '(e.g., the 800 in 800 X 600)
    On Error Resume Next
    CurrentHRes = GetDeviceCaps(objForm.hdc, HORZRES)
End Function

Public Function CurrentVRes(objForm As Object) As Long
    'returns current Vertical Resolution in Pixels
    '(e.g., the 600 in 800 X 600)
    On Error Resume Next
    CurrentVRes = GetDeviceCaps(objForm.hdc, VERTRES)
End Function

Public Function CurrentColorResolution(objForm As Object) As Long
    'returns the current color resolution in Bits
    On Error Resume Next
    CurrentColorResolution = GetDeviceCaps(objForm.hdc, _
       BITSPIXEL)
End Function

Public Function CurrentColorResolutionString(objForm As Object) _
As String

'returns the current color resolution as a string
    Dim i As Integer
    Dim sAns As String

On Error Resume Next
    
    i = CurrentColorResolution(objForm)
    Select Case i
    Case 4
        sAns = "16 Color"
    Case 8
        sAns = "256 Color"
    Case 16
        sAns = "High Color"
    Case 24, 32
        sAns = "True Color"
        
    End Select
    
     CurrentColorResolutionString = sAns

End Function

Private Sub Class_Initialize()
    Dim dMode As Long
    Dim r As Long, i As Integer
    Dim DM As DEVMODE

ReDim Preserve AvailScrRes(10) As DEVMODE

DM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    DM.dmSize = LenB(DM)
    Do While EnumDisplaySettings(0&, dMode, DM) > 0
        If i Mod 10 = 0 Then ReDim Preserve AvailScrRes(i + 10)
        AvailScrRes(i) = DM
        dMode = dMode + 1
        i = i + 1
    Loop
    piAvailableDisplayModes = i
End Sub