Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0677: Linearen Farbverlauf mit frei wählbarem Winkel per GDI+ erstellen

 von 

Beschreibung 

Dieses Beispiel zeigt, wie per GDI+ ein linearer Farbverlauf erstellt werden kann. Dabei können die Start- und die Endfarbe des Verlaufs und dessen Richtung festgelegt werden. Zudem können Polygone und Kreissektoren mit einem Verlauf gefüllt werden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

GdipCreateFromHDC, GdipCreateLineBrushFromRectWithAngleI, GdipDeleteBrush, GdipDeleteGraphics, GdipFillRectangleI, GdiplusShutdown, GdiplusStartup

Download:

Download des Beispielprojektes [10,09 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------ Anfang Projektdatei GDIPlusLinearGradient.vbp  ------
'--- Anfang Formular "frmGDIPlusLinearGradient" alias frmGDIPlusLinearGradient.frm  ---
' Steuerelement: Horizontale Scrollbar "hscToColor" (Index von 0 bis 2)
' Steuerelement: Horizontale Scrollbar "hscFromColor" (Index von 0 bis 2)
' Steuerelement: Bildfeld-Steuerelement "picGradient"
' Steuerelement: Horizontale Scrollbar "hscAngle"
' Steuerelement: Beschriftungsfeld "lblInfo" (Index von 0 bis 2)

Option Explicit

' ----==== GDI+ Konstanten ====----
Private Const GdiPlusVersion As Long = 1&

' ----==== sonstige Typen ====----
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' ----==== GDI+ Typen ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GdiplusStartupOutput
    NotificationHook As Long
    NotificationUnhook As Long
End Type

' ----==== GDI+ Enumerationen ====----
' GDI+ Status
Private Enum Status
    OK = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

Private Enum WrapMode
    WrapModeTile = 0
    WrapModeTileFlipX = 1
    WrapModeTileFlipY = 2
    WrapModeTileFlipXY = 3
    WrapModeClamp = 4
End Enum

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hDC As Long, ByRef graphics As Long) As Status

Private Declare Function GdipCreateLineBrushFromRectWithAngleI _
    Lib "gdiplus" (ByRef RECT As RECT, ByVal color1 As Long, _
    ByVal color2 As Long, ByVal angle As Single, _
    ByVal isAngleScalable As Long, ByRef WrapMode As WrapMode, _
    ByRef lineGradient As Long) As Long

Private Declare Function GdipDeleteBrush Lib "gdiplus" _
    (ByVal brush As Long) As Long

Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
    (ByVal graphics As Long) As Status

Private Declare Function GdipFillRectangleI Lib "gdiplus" _
    (ByVal graphics As Long, ByVal brush As Long, _
    ByVal X As Long, ByVal Y As Long, _
    ByVal Width As Long, ByVal Height As Long) As Status

Private Declare Function GdiplusShutdown Lib "gdiplus" _
    (ByVal token As Long) As Status

Private Declare Function GdiplusStartup Lib "gdiplus" _
    (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
    ByRef lpOutput As GdiplusStartupOutput) As Status

' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean

'------------------------------------------------------
' Funktion     : AngleGradient
' Beschreibung : Gradient mit variablen Winkel zeichnen
' Übergabewert : PicBox = PictureBox
'                lStartColor = Startfarbe des Gradient
'                lEndColor = Endfarbe des Gradient
'                sGradientAngle = Winkel des Gradient
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function AngleGradient(ByRef PicBox As PictureBox, _
    ByVal lStartColor As Long, ByVal lEndColor As Long, _
    ByVal sGradientAngle As Single) As Status
    
    Dim lngGraphics As Long
    Dim lngBrush As Long
    Dim tRect As RECT
    
    ' größe des Brushobjekts und
    ' der Ausgabe festlegen
    tRect.Left = 0
    tRect.Top = 0
    tRect.Right = PicBox.ScaleWidth
    tRect.Bottom = PicBox.ScaleHeight
    
    ' Graphicsobjekt vom Hdc erstellen -> lngGraphics
    If Execute(GdipCreateFromHDC(PicBox.hDC, _
    lngGraphics)) = OK Then
        
        ' Brushobjekt erstellen -> lngBrush
        If Execute(GdipCreateLineBrushFromRectWithAngleI(tRect, _
        lStartColor, lEndColor, sGradientAngle, CLng(Abs(False)), _
        WrapModeClamp, lngBrush)) = OK Then
            
            ' Brushobjekt in das Graphicsobjekt zeichnen
            AngleGradient = _
            Execute(GdipFillRectangleI(lngGraphics, lngBrush, _
            tRect.Left, tRect.Top, tRect.Right, tRect.Bottom))
            
            ' Brushobjekt löschen
            Call Execute(GdipDeleteBrush(lngBrush))
        End If
        
        ' Graphicsobjekt löschen
        Call Execute(GdipDeleteGraphics(lngGraphics))
        
        ' PictureBox refreshen
        PicBox.Refresh
    End If
End Function

'------------------------------------------------------
' Funktion     : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
'                GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function Execute(ByVal lReturn As Status) As Status
    Dim lCurErr As Status
    If lReturn = OK Then
        lCurErr = OK
    Else
        lCurErr = lReturn
        MsgBox GdiErrorString(lReturn) & " GDI+ Error:" & _
        lReturn, vbOKOnly, "GDI Error"
    End If
    Execute = lCurErr
End Function

'------------------------------------------------------
' Funktion     : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
'------------------------------------------------------
Private Function GdiErrorString(ByVal lError As Status) As String
    Dim s As String
    
    Select Case lError
    Case GenericError:              s = "Generic Error."
    Case InvalidParameter:          s = "Invalid Parameter."
    Case OutOfMemory:               s = "Out Of Memory."
    Case ObjectBusy:                s = "Object Busy."
    Case InsufficientBuffer:        s = "Insufficient Buffer."
    Case NotImplemented:            s = "Not Implemented."
    Case Win32Error:                s = "Win32 Error."
    Case WrongState:                s = "Wrong State."
    Case Aborted:                   s = "Aborted."
    Case FileNotFound:              s = "File Not Found."
    Case ValueOverflow:             s = "Value Overflow."
    Case AccessDenied:              s = "Access Denied."
    Case UnknownImageFormat:        s = "Unknown Image Format."
    Case FontFamilyNotFound:        s = "FontFamily Not Found."
    Case FontStyleNotFound:         s = "FontStyle Not Found."
    Case NotTrueTypeFont:           s = "Not TrueType Font."
    Case UnsupportedGdiplusVersion: s = "Unsupported Gdiplus Version."
    Case GdiplusNotInitialized:     s = "Gdiplus Not Initialized."
    Case PropertyNotFound:          s = "Property Not Found."
    Case PropertyNotSupported:      s = "Property Not Supported."
    Case Else:                      s = "Unknown GDI+ Error."
    End Select
    
    GdiErrorString = s
End Function

'------------------------------------------------------
' Funktion     : ShutdownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function ShutdownGDIPlus() As Status
    ' Beendet GDI+ Instanz
    ShutdownGDIPlus = GdiplusShutdown(GdipToken)
End Function

'------------------------------------------------------
' Funktion     : StartUpGDIPlus
' Beschreibung : Initialisiert GDI+ Instanz
' Übergabewert : GDI+ Version
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Status
    ' Initialisieren der GDI+ Instanz
    Dim GdipStartupInput As GDIPlusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    
    GdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, _
    GdipStartupInput, GdipStartupOutput)
End Function

Private Sub UpdateScroll()
    
    Dim lngStartColor As Long
    Dim lngEndColor As Long
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' die Farbwerte müssen als ARGB-Long übergeben werden
        ' ARGB = RGB(B, G, R) or &HFF000000
        lngStartColor = RGB(hscFromColor(2).Value, _
        hscFromColor(1).Value, hscFromColor(0).Value) _
        Or &HFF000000
        
        ' ARGB = RGB(B, G, R) or &HFF000000
        lngEndColor = RGB(hscToColor(2).Value, _
        hscToColor(1).Value, hscToColor(0).Value) _
        Or &HFF000000
        
        ' Gradient erzeugen
        Call AngleGradient(picGradient, lngStartColor, _
        lngEndColor, CSng(hscAngle.Value))
        
    End If
End Sub

Private Sub Form_Load()
    
    Dim z As Long
    
    GdipInitialized = False
    
    ' Formparameter setzen
    With Me
        .Height = 5000
        .Width = 5130
    End With
    
    ' Pictureboxparameter setzen
    With picGradient
        .AutoRedraw = True
        .Move 60, 60, 4905, 2745
        .ScaleMode = vbPixels
    End With
    
    ' Labelparameter setzen
    With lblInfo(0)
        .Alignment = 2
        .Caption = "Startfarbe Gradient"
        .Move 60, 60 + picGradient.Top + _
        picGradient.Height, 2385, 225
    End With
    
    ' Labelparameter setzen
    With lblInfo(1)
        .Alignment = 2
        .Caption = "Endfarbe Gradient"
        .Move 60 + lblInfo(0).Left + lblInfo(0).Width, _
        60 + picGradient.Top + picGradient.Height, _
        2385, 225
    End With
    
    ' Scrollbarparameter setzen
    For z = 0 To 2
        With hscFromColor(z)
            .Min = 0
            .Max = 255
            .Value = 0
            
            If z = 0 Then
                .Move 60, 60 + lblInfo(0).Top + _
                lblInfo(0).Height, 2385, 225
            Else
                .Move 60, 60 + hscFromColor(z - 1).Top + _
                hscFromColor(z - 1).Height, 2385, 225
            End If
        End With
    Next z
    
    ' Scrollbarparameter setzen
    For z = 0 To 2
        With hscToColor(z)
            .Min = 0
            .Max = 255
            .Value = 255
            
            If z = 0 Then
                .Move lblInfo(1).Left, 60 + lblInfo(1).Top _
                + lblInfo(1).Height, 2385, 225
            Else
                .Move hscToColor(z - 1).Left, _
                60 + hscToColor(z - 1).Top + _
                hscToColor(z - 1).Height, 2385, 225
            End If
        End With
    Next z
    
    ' Labelparameter setzen
    With lblInfo(2)
        .Alignment = 2
        .Caption = "Winkel Gradient"
        .Move 60, 60 + hscFromColor(2).Top + _
        hscFromColor(2).Height, hscToColor(2).Left + _
        hscToColor(2).Width - 60, 225
    End With
    
    ' Scrollbarparameter setzen
    With hscAngle
        .Move 60, 60 + lblInfo(2).Top + _
        lblInfo(2).Height, lblInfo(2).Width, 225
        .Min = 0
        .Max = 360
        .Value = 0
    End With
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' Gradient zeichnen
        Call UpdateScroll
    Else
        ' Initialisierung fehlgeschlagen
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub

Private Sub hscAngle_Change()
    Call hscAngle_Scroll
End Sub

Private Sub hscAngle_Scroll()
    ' Gradient zeichnen
    Call UpdateScroll
End Sub

Private Sub hscFromColor_Change(Index As Integer)
    Call hscFromColor_Scroll(Index)
End Sub

Private Sub hscFromColor_Scroll(Index As Integer)
    ' Gradient zeichnen
    Call UpdateScroll
End Sub

Private Sub hscToColor_Change(Index As Integer)
    Call hscToColor_Scroll(Index)
End Sub

Private Sub hscToColor_Scroll(Index As Integer)
    ' Gradient zeichnen
    Call UpdateScroll
End Sub
'--- Ende Formular "frmGDIPlusLinearGradient" alias frmGDIPlusLinearGradient.frm  ---
'------- Ende Projektdatei GDIPlusLinearGradient.vbp  -------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.