Hintergrundfarbe einer Zelle auslesen

Beispieldatei (Zellfarben.zip 17 kB)

Die Hintergrundfarbe einer Zelle auszulesen ist eigentlich ganz einfach.

Setzt man aber die bedingte Formatierung ein, liefert die Zeile
ActiveCell.Interior.ColorIndex
möglicherweise falsche Werte.

Meine Idee geht dahin, die Zelle als Bitmap in die Zwischenablage zu schaufeln und anschließend in einen DC zu kopieren. Danach kann man die Farben aller Pixel auslesen und die Farbe, die am häufigsten vorkommt ist dann die Hintergrundfarbe.
Natürlich funzt das nur, wenn man kein besonderes Muster gewählt hat. Theoretisch könnte man auch noch die Textfarbe extrahieren, wenn man die Farbe der Gitternetzlinien herausrechnet.
Wirklich Praxistauglich ist das aber nicht, da der ganze Kram ziemlich langsam ist und auch sonst einige mögliche Fehlerquellen enthält. Wenn man sicher gehen will, sollte man die Bedingungen überprüfen.
Um zu zeigen, dass so etwas grundsätzlich möglich ist, hier der Code dazu:

Option Explicit
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetPixel _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal X As Long, _
   ByVal Y As Long _
   ) As Long
Private Declare Function GetObject _
   Lib "gdi32" Alias "GetObjectA" ( _
   ByVal hObject As Long, _
   ByVal nCount As Long, _
   lpObject As Any _
   ) As Long
Private Declare Function CloseClipboard _
   Lib "user32" () As Long
Private Declare Function OpenClipboard _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Function EmptyClipboard _
   Lib "user32" () As Long
Private Declare Function GetClipboardData _
   Lib "user32" ( _
   ByVal wFormat As Long _
   ) As Long
Private Declare Function IsClipboardFormatAvailable _
   Lib "user32" ( _
   ByVal wFormat As Long _
   ) As Long
Private Declare Function SelectObject _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal hObject As Long _
   ) As Long
Private Declare Function CreateCompatibleDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function DeleteDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Const CF_BITMAP = 2

Sub test()
Dim strFarbe As String
   strFarbe = MyCellColor(Worksheets(1).Range("O1"))
    MsgBox _
    "Rot = " & Right(strFarbe, 2) & vbCrLf & _
    "Grün = " & Mid(strFarbe, 3, 2) & vbCrLf & _
    "Blau = " & Left(strFarbe, 2)
End Sub

Public Function MyCellColor(objRange As Range)
Dim hBitmap       As Long
Dim hOldBitmap    As Long
Dim lngDC         As Long
Dim udtBMP        As BITMAP
Dim lngBreite     As Long
Dim lngHöhe       As Long
Dim lngFarbe      As Long
Dim bytRot        As Byte
Dim bytGrün       As Byte
Dim bytBlau       As Byte
Dim strHexFarbe   As String
Dim lngMax        As Long
Dim i             As Long
Dim k             As Long
Dim lngAnzahl     As Long
Dim colFarben     As New Collection
Dim colItem       As Collection
Dim varItem       As Variant

On Error Resume Next

' 1 Zelle des Bereichs
Set objRange = objRange.Cells(1)

'Den Bereich als Bitmap in die Zwischenablage bringen
objRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

' Clipboard öffnen
OpenClipboard 0&

If IsClipboardFormatAvailable(CF_BITMAP) Then
   'Im Clipboard ist eine Bitmap
   
   'Einen zum Screen kompatiblen Devicekontext erzeugen
   lngDC = CreateCompatibleDC(0)
   
   'Zugriffsnummer auf Bitmap im Clip holen
   hBitmap = GetClipboardData(CF_BITMAP)
   
   If (hBitmap) Then
   
      'Die Struktur BMP mit Infos füllen
      GetObject hBitmap, Len(udtBMP), udtBMP
      
      'Die Bitmap in den erzeugten DC stellen
      hOldBitmap = SelectObject(lngDC, hBitmap)
      
      ' Ausmaße der Bitmap
      lngBreite = udtBMP.bmWidth
      lngHöhe = udtBMP.bmHeight
      
      ' Die Farben aller Pixel auslesen
      For i = 1 To lngHöhe
         For k = 1 To lngBreite
         
            ' Pixelfarbe ermitteln
            lngFarbe = GetPixel(lngDC, k, i)
            
            ' In einen Hexstring umwandeln
            strHexFarbe = String(6 - Len(Hex(lngFarbe)), _
               Asc("0")) & Hex(lngFarbe)
               
            Err.Clear
            
            ' Eine neue Collection erzeugen
            Set colItem = New Collection
            
            ' Farbe und Anzahl als Item hinzufügen
            colItem.Add strHexFarbe, "Farbe"
            colItem.Add 1, "Anzahl"
            
            colFarben.Add colItem, strHexFarbe
            
            If Err.Number <> 0 Then
               lngAnzahl = colFarben(strHexFarbe)("Anzahl") + 1
               
               ' Eine neue Collection erzeugen
               Set colItem = New Collection
               
               ' Farbe und Anzahl als Item hinzufügen
               colItem.Add strHexFarbe, "Farbe"
               colItem.Add lngAnzahl, "Anzahl"
               
               ' Das Item entfernen
               colFarben.Remove strHexFarbe
               
               ' Ein neues mit den geänderten Werten hinzu
               colFarben.Add colItem, strHexFarbe
               
            End If
         Next
      Next
      
'      Gitternetzlinienfarbe entfernen
'      colFarben.Remove "C0C0C0"

      lngMax = 0
      For Each varItem In colFarben
         ' Die häufigste Farbe ist der Hintergrund
         If varItem("Anzahl") > lngMax Then
            lngMax = varItem("Anzahl")
            MyCellColor = varItem("Farbe")
         End If
      Next
      
      ' Clipboard leeren
      EmptyClipboard
      
      ' Clipboard schließen
      CloseClipboard
      
      ' Die alte Bitmap in den DC stellen
      SelectObject lngDC, hOldBitmap
      
      ' Erzeugten DC löschen
      DeleteDC lngDC
      
   End If
   
End If

End Function