Zurück zur Homepage

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 As Long, _
   
ByVal 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