Ermitteln der aktuellen Farbpalette (Farbtiefe) Dieser Tipp zeigt, wie man die aktuell im System eingestellte Farbpalette (Farbtiefe) ermittelt.
Autor:   Microsys Kramer	Bewertung:	Views:  8.559
www.access-paradies.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Mit nachfolgendem Code lässt sich ermitteln, welche Farbpalette (Farbtiefe) im System aktuell eingestellt ist.

Fügen Sie den Code am besten in ein Modul:

Option Explicit
 
' Benötigte API-Deklarationen 
Private Declare Function api_GetDeviceCaps Lib "gdi32" _
  Alias "GetDeviceCaps" ( _
  ByVal hdc As Long, _
  ByVal nIndex As Long) As Long
 
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_DeleteDC Lib "gdi32" _
  Alias "DeleteDC" ( _
  ByVal hdc As Long) As Long

' // -----------------------------------------------------------------
' // Funktion:  | Farbpalette_ermitteln
' // -----------------------------------------------------------------
' // Methode:   | Ermittelt die aktuelle Farbpalette
' // -----------------------------------------------------------------
Public Function Farbpalette_ermitteln() As String
  On Error GoTo Err_Farbpalette_ermitteln
 
  Dim Planes  As Integer
  Dim Bits    As Integer
 
  Planes = Getdevcaps(14)
  Bits = Getdevcaps(12)
 
  If Planes = 1 Then
    Select Case Bits
      Case 8
        Farbpalette_ermitteln = "256 Farben"
      Case 15
        Farbpalette_ermitteln = "32768 Farben"
      Case 16
        Farbpalette_ermitteln = "65536  Farben" ' "High Color (16 Bit)"
      Case 24
        Farbpalette_ermitteln = "16777216 Farben"
      Case 32
        Farbpalette_ermitteln = "True Color (32 Bit)"
    End Select
  ElseIf Planes = 4 Then
    Farbpalette_ermitteln = "16 Farben"
  Else
    Farbpalette_ermitteln = "Unbekannt"
  End If
 
Exit_Farbpalette_ermitteln:
  Exit Function
 
Err_Farbpalette_ermitteln:
  Farbpalette_ermitteln = "Unbekannt"
  Resume Exit_Farbpalette_ermitteln
End Function

Public Function Getdevcaps%(ByVal intCapability As Integer)
  On Error GoTo Err_Getdevcaps
 
  Dim hdc As Long
 
  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:
  Getdevcaps = ""
  Resume Exit_Getdevcaps
End Function

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.