vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Blitzschnelles Erstellen von grafischen Diagrammen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Grafik und Font · Sonstiges   |   VB-Versionen: VB5, VB609.01.07
AutoColor - autom. Farbanpassung

Anpassen der Hintergrundfarbe an den Hintergrund eines Bildes in einer PictureBox

Autor:   Andreas MascheckBewertung:     [ Jetzt bewerten ]Views:  9.803 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

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

Dieser Tipp wurde bereits 9.803 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel