Stört Sie das eintönige Grau von Windows? Möchten Sie Ihre Anwendungen optisch "aufpeppen"? ' 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 27.596 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 TOP! Unser Nr. 1 Neu! sevDataGrid 3.0 Mehrspaltige Listen, mit oder ohne DB-Anbindung. Autom. Sortierung, Editieren von Spalteninhalten oder das interaktive Hinzufügen von Datenzeilen sind ebenso möglich wie das Erstellen eines Web-Reports. |
||||||||||||||||
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. |