Option Explicit
 
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
 
Const CCDEVICENAME As Long = 32&
Const CCFORMNAME As Long = 32&
Const DM_BITSPERPEL As Long = &H40000
Const DM_PELSWIDTH As Long = &H80000
Const DM_PELSHEIGHT As Long = &H100000
Const CDS_UPDATEREGISTRY As Long = &H1&
Const CDS_TEST As Long = &H4&
Const CDS_FULLSCREEN As Long = &H4
Const DISP_CHANGE_SUCCESSFUL As Long = 0&
Const DISP_CHANGE_RESTART As Long = 1&
Const ENUM_CURRENT_SETTINGS As Long = -1&
Const DM_DISPLAYFREQUENCY As Long = &H400000
 
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
 
Dim SystemMode As DEVMODE
Dim GameMode As DEVMODE
 
Public Function SetScreen(ByVal Game As Boolean) As Boolean
Dim Result As Long
 
If Game Then
    Result = EnumDisplaySettings(0&, ENUM_CURRENT_SETTINGS, SystemMode)
    If Result = 0 Then GoTo errhandler
    If PickResolution = False Then GoTo errhandler
    'GameMode.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    Result = ChangeDisplaySettings(GameMode, CDS_TEST)
    ChangeDisplaySettings GameMode, CDS_FULLSCREEN
Else
    Result = ChangeDisplaySettings(SystemMode, CDS_TEST)
    ChangeDisplaySettings SystemMode, CDS_FULLSCREEN
End If
 
SetScreen = True
Exit Function
errhandler:
SetScreen = False
End Function
 
Private Function PickResolution() As Boolean
On Local Error GoTo errhandler
Dim Capabilities() As DEVMODE
Dim Pickabilities() As DEVMODE
ReDim Capabilities(0 To 0)
Dim PickResult As Long
Dim ModeIndex As Long
'ALLE verfügbaren Modi sammeln
Do
PickResult = EnumDisplaySettings(0&, ModeIndex, Capabilities(ModeIndex))
If PickResult <> 0 Then
    ModeIndex = ModeIndex + 1
    ReDim Preserve Capabilities(0 To ModeIndex)
End If
DoEvents
Loop Until PickResult = 0
ReDim Preserve Capabilities(0 To ModeIndex - 1)
ReDim Pickabilities(0 To 0)
Dim i As Integer
 
'Alle Modi mit 1024x768 und einer Farbtiefe größer 15bit sammeln
 
For i = 0 To UBound(Capabilities)
If Capabilities(i).dmPelsWidth = 1024 And Capabilities(i).dmPelsHeight = 768 _
  And Capabilities(i).dmBitsPerPel > 15 Then
    Pickabilities(UBound(Pickabilities)) = Capabilities(i)
    ReDim Preserve Pickabilities(0 To UBound(Pickabilities) + 1)
End If
Next i
ReDim Preserve Pickabilities(0 To UBound(Pickabilities) - 1)
Capabilities = Pickabilities
ReDim Pickabilities(0 To 0)
'Höchste Farbtiefe herausfinden
Dim MaxDepth As Integer
For i = 0 To UBound(Capabilities)
If Capabilities(i).dmBitsPerPel > MaxDepth Then MaxDepth = Capabilities( _
  i).dmBitsPerPel
Next i
'Alle Modi aussortieren, die nicht der höchsten Farbtiefe entsprechen
For i = 0 To UBound(Capabilities)
If Capabilities(i).dmBitsPerPel = MaxDepth Then
    Pickabilities(UBound(Pickabilities)) = Capabilities(i)
    ReDim Preserve Pickabilities(0 To UBound(Pickabilities) + 1)
End If
Next i
ReDim Preserve Pickabilities(0 To UBound(Pickabilities) - 1)
Capabilities = Pickabilities
'Höchste Refreshrate finden
MaxDepth = 0
Dim PickIndex As Integer
For i = 0 To UBound(Capabilities)
    If Capabilities(i).dmDisplayFrequency > MaxDepth Then
        MaxDepth = Capabilities(i).dmDisplayFrequency
        PickIndex = i
    End If
Next i
GameMode = Capabilities(PickIndex)
PickResolution = True
Exit Function
errhandler:
PickResolution = False
End Function