Attribute VB_Name = "modScreenResize"
Option Explicit

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32

Private Const BITSPIXEL = 12
Private Const PLANES = 14

Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Const DISP_CHANGE_FAILED = -1
Private Const DISP_CHANGE_BADMODE = -2
Private Const DISP_CHANGE_NOTUPDATED = -3
Private Const DISP_CHANGE_BADFLAGS = -4
Private Const DISP_CHANGE_BADPARAM = -5

Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H2

Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000

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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As Any, ByVal lpOutput As Any, ByVal lpInitData As Any) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long

Function ChangeScreenSettings(lWidth As Integer, lHeight As Integer, lColors As Integer)
    Dim tDevMode As DEVMODE, lTemp As Long, lIndex As Long
    ' Declare variables
    lIndex = 0
    Do
        'Instilise Do loop
        lTemp = EnumDisplaySettings(0&, lIndex, tDevMode)
        ' Call the APi function
        If lTemp = 0 Then Exit Do
            ' If there is no more data or an erro occurs
            ' then return 0 and exit do
            lIndex = lIndex + 1
            ' Increase the index to be enumerated

            With tDevMode
                If .dmPelsWidth = lWidth And .dmPelsHeight = lHeight And .dmBitsPerPel = lColors Then
                    lTemp = ChangeDisplaySettings(tDevMode, CDS_UPDATEREGISTRY)
                    'bool check here for successful change - set to true
                    changeSuccessful = True
                    Exit Do
                End If
            End With
  
            ' Set the new data
            ' Change the display type. This depends on the paramter used
            ' It can either be:
            ' 0 - Dynamic change if possible
            ' CDS_UPDATEREGISTRY - Dynamically change if possible
            ' and if not possibel then  update registry for change
            ' on the next boot-up
            ' CDS_TEST - Test the new settings
    Loop

    Select Case lTemp
        ' Check for errors
        Case DISP_CHANGE_SUCCESSFUL
            'MsgBox "The display settings change was successful", vbInformation
        Case DISP_CHANGE_RESTART
            'MsgBox "The computer must be restarted in order for the graphics mode to work", vbQuestion
        Case DISP_CHANGE_FAILED
            'MsgBox "The display driver failed the specified graphics mode", vbCritical
        Case DISP_CHANGE_BADMODE
            'MsgBox "The graphics mode is not supported", vbCritical
        Case DISP_CHANGE_NOTUPDATED
            'MsgBox "Unable to write settings to the registry", vbCritical
            ' NB. Windows NT Only
        Case DISP_CHANGE_BADFLAGS
            'MsgBox "An invalid set of flags was passed in", vbCritical
    End Select
End Function

Public Function GetScreenResolution() As String
    Dim lTemp As String
    ' Temporary string to hold returned screen
    ' resolution
    
    
    lTemp = GetSystemMetrics(SM_CXSCREEN) & "x" & GetSystemMetrics(SM_CYSCREEN)
    ' Call the API function twice to return
    ' screen size for each axis as format into
    ' the temporary string
    GetScreenResolution = lTemp
End Function

Public Function GetAvailableColours() As String
    Dim lHdc As Long, lPlanes As Long, lBitsPerPixel As Integer
    ' Declare variables

    lHdc = CreateIC("DISPLAY", 0&, 0&, 0&)
    ' Create the device context for the display

    If lHdc = 0 Then
        ' An error has occurred and the function will exit
        GetAvailableColours = "Error"
        Exit Function
    End If

    lPlanes = GetDeviceCaps(lHdc, PLANES)
    ' Return info on number of planes

    lBitsPerPixel = GetDeviceCaps(lHdc, BITSPIXEL)
    ' Use display device context to return info on the
    ' number of pixels

    lHdc = DeleteDC(lHdc)
    ' Delete the device context

    Select Case lPlanes
        Case 1
            ' 1 plane is available. This will be the same for most
            ' computer systems
            Select Case lBitsPerPixel
                ' Select the number of colours available
                Case 4: GetAvailableColours = "4 Bit, 16 Colours"
                Case 8: GetAvailableColours = "8 Bit, 256 Colours"
                Case 16: GetAvailableColours = "16 Bit, 65536 Colours"
                Case 24: GetAvailableColours = "24 Bit True Colour, 16.7 Million Colours"
                Case 32: GetAvailableColours = "32 Bit True Colour, 16.7 Million Colours"
            End Select
        Case 4
            GetAvailableColours = "16 Bit, 65536 Colours"
            ' If there are 4 planes then the availible
            ' colours will be 16-bit
        Case Else
            GetAvailableColours = "Undetermined"
            ' The number of colours could not bee determined
    End Select
End Function

Public Function GetCurrentXSetting() As Integer
    GetCurrentXSetting = GetSystemMetrics(SM_CXSCREEN)
End Function

Public Function GetCurrentYSetting() As Integer
    GetCurrentYSetting = GetSystemMetrics(SM_CYSCREEN)
End Function