Die Community zu .NET und Classic VB.

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

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

 von Frank Schüler

Schwierigkeitsgrad:

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  -------