AutoColor - autom. Farbanpassung Anpassen der Hintergrundfarbe an den Hintergrund eines Bildes in einer PictureBox
Autor:   Andreas Mascheck	Bewertung:     [ Jetzt bewerten ]	Views:  11.443
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 5 Bewertung insgesamt: nützlich Durchschnittliche Bewertung: 2.8 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Zur Programmierung eines Wallpaperwechslers habe ich eine Möglichkeit gesucht, um bei zentrierter Anzeige oder großen gleichmäßigen Farbflächen den Desktop Hintergrund farblich anzupassen. Die Schrift der Icons ist dann meist günstiger zu lesen.

Dazu ist die entsprechende Windows Funktion zu vereinbaren:

' Benötigte API-Deklaration
Private Declare Function SetSysColors Lib "user32" ( _
  ByVal nChanges As Long, _
  lpSysColor As Long, _
  lpColorValues As Long) As Long

Im Programm wird die Funktion wie folgt aufgerufen:

' Bildschirmhintergrund anpassen
' Call SetSysColors(1, 1, CommonDialog1.Color)
Call SetSysColors(1, 1, Farbe)

Woher aber nehmen?? Angenommen das Bild ist bereits in einer PictureBox, dann habe ich folgende Lösung gefunden:

Private Function checkFarbe(vpicQuelle As PictureBox) As Long
  Dim f1 As Long
  Dim f2 As Long
  Dim f3 As Long
  Dim farbe As Long
  Dim i As Long
  Dim x As Long
  Dim y As Long
  Dim j As Integer
  Dim Histogramm(512) As Long
  Dim Phist As Long
  Dim MaxH As Long
  Dim b1 As Byte
  Dim b2 As Byte
  Dim b3 As Byte
  Dim fehler
  Dim z As Integer
 
  f1 = f2 = f3 = 0
  For i = 1 To 512
    Histogramm(i) = 0
  Next i
 
  ' in der oberen linken Ecke die häufigste Farbe finden
  For i = 1 To 100
    farbe = pickFarbe(vpicQuelle)
    ' RGB-Farbwert ermitteln
    b1 = R(farbe) 
    b2 = G(farbe) 
    b3 = B(farbe) 
    ' Debug.Print b1, b2, b3
 
    ' Farbraum in 512 Würfel teilen - neue Farbadresse bilden
    Phist = Int((b1) / 32)
    Phist = Phist * 8 + Int((b2) / 32)
    Phist = Phist * 8 + Int((b3) / 32)
 
    ' zählen der Farbwürfel
    Histogramm(Phist) = Histogramm(Phist) + 1
  Next i
 
  ' Maximal vorhandene Farbe finden
  MaxH = 0
  For i = 0 To 512
    If Histogramm(i) > Histogramm(MaxH) Then MaxH = i
  Next i
 
  ' die Farbwürfel wieder aufdröseln zu RGB - ist noch sehr grob
  f1 = Int((MaxH And 127) * 2)
  f2 = Int((MaxH And 63) * 4)
  f3 = Int((MaxH And 7) * 32)
  ' Debug.Print "A: ", MaxH, f1, f2, f3
 
  ' ----------------------------------------------------
  ' Häufigste Farbe im Bild suchen und genau bestimmen.
  ' Hier werden zufällig Farbpunkte vom Bild entnommen.
  ' Wenn unpassend, wird die Toleranzgrenze erhöht 
  ' (i hat gerade gepasst) bis was passt und dann aber
  ' nichts wie weg hier
  z = 0
  For i = 1 To 200
    farbe = pickFarbe(vpicQuelle)
    b1 = R(farbe)
    b2 = G(farbe)
    b3 = B(farbe)
    fehler = ((b1 - f1) ^ 2 + (b2 - f2) ^ 2 + (b3 - f3) ^ 2) ^ 0.5
    If fehler < i Then ' es wäre auch irgendein faktor*i denkbar
      z = z + 1
      Exit For
  End If
  Next i
  If z > 0 Then
    f1 = b1
    f2 = b2
    f3 = b3
  Else
    Debug.Print fehler ' das passiert so gut wie nie
  End If
  ' Debug.Print "B: ", MaxH, f1, f2, f3
  checkFarbe = RGB(f1, f2, f3)
End Function

Private Function pickFarbe(vQuelle As PictureBox) As Long
  ' der eigentliche Farbpicker
  Dim x As Long
  Dim y As Long
  Dim lang As Long
 
  ' hoch oder Querformat?
  If vQuelle.Width > vQuelle.Height Then 
    lang = vQuelle.Height / 4
  Else
    lang = vQuelle.Width / 4
  End If
  x = 80 + Int(lang * Rnd)
  y = 80 + Int((lang - x) * Rnd)
  pickFarbe = vQuelle.Point(x, y)
End Function

' Farbanteil BLAU
Private Function B(ByVal Color As Long) As Integer
  B = Color \ &H10000 And &HFF&
End Function
 
' Farbanteil ROT
Private Function R(ByVal Color As Long) As Integer
  R = Color And &HFF&
End Function
 
' Farbanteil GRÜN
Private Function G(ByVal Color As Long) As Integer
  G = Color \ &H100& And &HFF&
End Function