vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
SEPA-Dateien erstellen inkl. IBAN-, BLZ-/Kontonummernprüfung  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2021
 
zurück
Rubrik: Oberfläche · Fenster   |   VB-Versionen: VB4, VB5, VB625.02.01
Farbverlauf in Fenstern und Objekten

Stört Sie das eintönige Grau von Windows? Möchten Sie Ihre Anwendungen optisch aufpeppen? Dann ist dieser Tipp genau richtig.

Autor:   Dieter OtterBewertung:     [ Jetzt bewerten ]Views:  26.529 
www.tools4vb.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Stört Sie das eintönige Grau von Windows? Möchten Sie Ihre Anwendungen optisch "aufpeppen"?
Dann probieren Sie mal folgende Routine:
Die nachfolgende Prozedur erzeugt einen Hintergrund-Farbverlauf für ein bestimmtes Formular. Setzen Sie zunächst die AutoRedraw-Eigenschaft auf True und rufen dann die Prozedur MakeGradient auf.

Anmerkung: Das Erzeugen des Farbverlaufs lässt sich ohne weiteres auch auf Picture-Objekte anwenden.

' zunächst die benötigten API-Funktionen
Private Declare Function DeleteObject Lib "gdi32" ( _
  ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
  ByVal crColor As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal nIndex As Long) As Long
Private Declare Function FillRect Lib "user32" ( _
  ByVal hDC As Long, _
  lpRect As RECT, _
  ByVal hBrush As Long) As Long
 
Private Const PLANES = 14
Private Const BITSPIXEL = 12
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
' Parameterbeschreibung
' Obj:  Form oder Picture-Objekt
' FromColor: Farbwert Anfangsfarbe
' ToColor:   Farbwert Endfarbe
' Direction: 1 = von oben nach unten
'           2 = von links nach rechts
 
Sub MakeGradient(Obj As Object, ByVal FromColor As Long, _
  ByVal ToColor As Long, ByVal Direction As Integer)
 
  Static ColorBits As Long
  Static RgnCnt As Integer
 
  Dim NbrPlanes As Long
  Dim BitsPerPixel As Long
  Dim AreaHeight As Long
  Dim AreaWidth As Long
  Dim prevScaleMode As Integer
  Dim IntervalX As Long
  Dim IntervalY As Long
  Dim I As Integer
  Dim R As Long
  Dim R_ColorVal As Long
  Dim G_ColorVal As Long
  Dim B_ColorVal As Long
  Dim FillArea As RECT
  Dim hBrush As Long
  Dim ColRed As Integer
  Dim ColGreen As Integer
  Dim ColBlue As Integer
 
  With Obj
    If ColorBits = 0 Then
      BitsPerPixel = GetDeviceCaps(.hDC, BITSPIXEL)
      NbrPlanes = GetDeviceCaps(.hDC, PLANES)
      ColorBits = (BitsPerPixel * NbrPlanes)
 
      Select Case ColorBits
        Case 32:  RgnCnt = 256
        Case 24:  RgnCnt = 256
        Case 16:  RgnCnt = 256
        Case 15:  RgnCnt = 32
        Case 8:   RgnCnt = 64
        Case 4:   RgnCnt = 64
        Case Else
          ColorBits = 4
          RgnCnt = 64
      End Select
    End If
 
    prevScaleMode = .ScaleMode
    .ScaleMode = 3
    AreaHeight = .ScaleHeight
    AreaWidth = .ScaleWidth
    .ScaleMode = prevScaleMode
 
    R_ColorVal = Int((ColorRed(FromColor) - _
     ColorRed(ToColor) + 1) / RgnCnt * 100)
    G_ColorVal = Int((ColorGreen(FromColor) - _
     ColorGreen(ToColor) + 1) / RgnCnt * 100)
    B_ColorVal = Int((ColorBlue(FromColor) - _
     ColorBlue(ToColor) + 1) / RgnCnt * 100)
 
    ColRed = ColorRed(ToColor) * 100
    ColGreen = ColorGreen(ToColor) * 100
    ColBlue = ColorBlue(ToColor) * 100
 
    IntervalY = Int(AreaHeight / RgnCnt * 100)
    IntervalX = Int(AreaWidth / RgnCnt * 100)
 
    With FillArea
      .Left = 0
      .Top = 0
      .Right = AreaWidth
      .Bottom = AreaHeight
    End With
 
    For I = 0 To RgnCnt - 1
      hBrush = CreateSolidBrush(RGB(ColRed / 100, _
       ColGreen / 100, ColBlue / 100))
      If Direction = 1 Then
        FillArea.Top = AreaHeight - (I * IntervalY / 100)
        R = FillRect(.hDC, FillArea, hBrush)
        FillArea.Bottom = FillArea.Top
      Else
        FillArea.Left = AreaWidth - (I * IntervalX / 100)
        R = FillRect(.hDC, FillArea, hBrush)
        FillArea.Right = FillArea.Left
      End If
      R = DeleteObject(hBrush)
      If I < RgnCnt - 1 Then
        ColRed = ColRed + R_ColorVal
        ColGreen = ColGreen + G_ColorVal
        ColBlue = ColBlue + B_ColorVal
      End If
    Next I
 
    FillArea.Top = 0
    FillArea.Left = 0
    hBrush = CreateSolidBrush(RGB(Int(ColRed / 100), _
     Int(ColGreen / 100), Int(ColBlue / 100)))
    R = FillRect(.hDC, FillArea, hBrush)
    R = DeleteObject(hBrush)
  End With
End Sub
 
' Farbanteil BLAU
Private Function ColorBlue(ByVal Color As Long) As Integer
  ColorBlue = Color \ &H10000 And &HFF&
End Function
 
' Farbanteil ROT
Private Function ColorRed(ByVal Color As Long) As Integer
  ColorRed = Color And &HFF&
End Function
 
' Farbanteil GRÜN
Private Function ColorGreen(ByVal Color As Long) As Integer
  ColorGreen = Color \ &H100& And &HFF&
End Function

Hier ein kleines Beispiel:

Private Sub Form_Load()
  ' Farbverlauf von Schwarz nach Weiß
  ' und oben nach unten
  MakeGradient Me, vbBlack, vbWhite, 1
End Sub
 
Private Sub Form_Resize()
  ' Wenn die Größe der Form verändert wird,
  ' muß der Farbverlauf neu gezeichnet werden!
  MakeGradient Me, vbBlack, vbWhite, 1
End Sub

Dieser Tipp wurde bereits 26.529 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-2021 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