Ermitteln der aktuellen Farbpalette (Farbtiefe) Dieser Tipp zeigt, wie man die aktuell im System eingestellte Farbpalette (Farbtiefe) ermittelt.
Autor:   Microsys Kramer	Bewertung:     [ Jetzt bewerten ]	Views:  1.308
www.access-paradies.de	System:  Win9x, WinNT, Win2000, WinXP, Vista	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Bisher wurde noch keine Bewertung abgegeben.

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

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