Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Declare Function SystemParametersInfo Lib "user32" _
    Alias "SystemParametersInfoA" _
    (ByVal uAction As Long, _
     ByVal uParam As Long, _
     lpvParam As Any, _
     ByVal fuWinIni As Long) _
     As Long
 
Global Const SPI_GETWORKAREA = 48

Private Declare Function apiGetSys Lib "user32" _
    Alias "GetSystemMetrics" _
    (ByVal nIndex As Long) As Long
 
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
 
Function fGetSysStuff(strWhat As String) As String
 
    Dim strRet As String
 
    Select Case LCase(strWhat)
        Case "resolution":
            strRet = apiGetSys(SM_CXSCREEN) & "x" _
                     & apiGetSys(SM_CYSCREEN)
        Case "windowsize":
            strRet = apiGetSys(SM_CXFULLSCREEN) & "x" _
                     & apiGetSys(SM_CYFULLSCREEN)
    End Select
 
    fGetSysStuff = strRet
 
End Function

Private Declare Function api_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 api_GetDeviceCaps Lib "gdi32" _
        Alias "GetDeviceCaps" _
        (ByVal hdc As Long, _
         ByVal nIndex As Long) _
         As Long
 
Private Declare Function api_DeleteDC Lib "gdi32" _
        Alias "DeleteDC" (ByVal hdc As Long) As Long
 
Public Function Farbpalette() As String
On Error GoTo Err_Farbpalette
 
    Dim Planes As Integer
    Dim Bits As Integer
 
    Planes = Getdevcaps(14)
    Bits = Getdevcaps(12)
 
    If Planes = 1 Then
        Select Case Bits
            Case 8
                Farbpalette = "256 Farben"
            Case 15
                Farbpalette = "32768 Farben"
            Case 16
                Farbpalette = "65536  Farben"
            Case 24
                Farbpalette = "16777216 Farben"
            Case 32
                Farbpalette = "True Color"
            End Select
    ElseIf Planes = 4 Then
        Farbpalette = "16 Farben"
    Else
        Farbpalette = "Unbekannt"
    End If
 
Exit_Farbpalette:
    Exit Function
 
Err_Farbpalette:
    Farbpalette = "Unbekannt"
    Resume Exit_Farbpalette
 
End Function
 
Public Function Getdevcaps%(ByVal intCapability%)
On Error GoTo Err_Getdevcaps
 
    Dim hdc&
 
    Const DRIVER_NAME = "DISPLAY"
    Const DEVICE_NAME = 0&
    Const OUTPUT_DEVICE = 0&
    Const LPDEVMODE = 0&
 
    hdc = api_CreateIC(DRIVER_NAME, DEVICE_NAME, OUTPUT_DEVICE, LPDEVMODE)
    If hdc Then
        Getdevcaps = api_GetDeviceCaps(hdc, intCapability)
        hdc = api_DeleteDC(hdc)
    End If
 
Exit_Getdevcaps:
    Exit Function
 
Err_Getdevcaps:
    MsgBox Err.Description
    Resume Exit_Getdevcaps
 
End Function

    Dim MyRect As RECT
 
    ' Infos über die Bildschirmauflösung
    Me![Auflösung] = fGetSysStuff("resolution") & " Pixel"
 
    ' Die folgenden Infos geben den verfügbaren Bereich wieder
    Me![Bereich] = fGetSysStuff("windowsize") & " Pixel"    
 
    SystemParametersInfo SPI_GETWORKAREA, 0, MyRect, 0
    With MyRect
        Me![Oben] = .Top & " Pixel"
        Me![Unten] = .Bottom & " Pixel"
        Me![Links] = .Left & " Pixel"
        Me![Rechts] = .Right & " Pixel"
    End With
 
    ' Mit der folgenden Funktion prüfen Sie die Farbpalette
    ' Als Rückwert wird Ihnen die Anzahl der Farben gegeben
    Me![Farben] = Farbpalette()