Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0673: Mittels GDI+ einen Farbverlauf entlang eines Pfades erzeugen

VB 5/6-Tipp 0673: Mittels GDI+ einen Farbverlauf entlang eines Pfades erzeugen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipAddPathLine2I, GdipCreateFromHDC, GdipCreatePath, GdipCreatePathGradientFromPath, GdipDeleteBrush, GdipDeleteGraphics, GdipDeletePath, GdipFillPath, GdipSetPathGradientCenterColor, GdipSetPathGradientCenterPointI, GdiplusShutdown, GdiplusStartup, GdipSetPathGradientLinearBlend (LinearBlend), GdipSetPathGradientSurroundColorsWithCount (SurroundColors)

Download: Download des Beispielprojektes [5,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 GdiPlusPathGradient.vbp  -------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'--- Anfang Formular "frmGdiPlusPathGradient" alias frmGdiPlusPathGradient.frm  ---
' Steuerelement: Horizontale Scrollbar "hscLinearBlend" (Index von 0 bis 1)
' Steuerelement: Horizontale Scrollbar "hscCenterPoint" (Index von 0 bis 1)
' Steuerelement: Bildfeld-Steuerelement "picGradient"
' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 5)
' basiert auf
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/
' gdicpp/GDIPlus/UsingGDIPlus/FillingShapeswithaGradientBrush/
' CreatingaPathGradient.asp

Option Explicit

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

' ----==== Sonstige Types ====----
Private Type POINT
    X As Long
    Y As Long
End Type

' ----==== GDI+ Types ====----
Private Type ARGB
    Blue As Byte
    Green As Byte
    Red As Byte
    Alpha As Byte
End Type

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+ Enums ====----
Private Enum FillMode
    FillModeAlternate = 0
    FillModeWinding = 1
End Enum

'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

' ----==== GDI+ API Declarationen ====----
Private Declare Function GdipAddPathLine2I Lib "gdiplus" _
    (ByVal path As Long, ByRef points As POINT, _
    ByVal Count As Long) As Status

Private Declare Function GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hDC As Long, ByRef graphics As Long) As Status

Private Declare Function GdipCreatePath Lib "gdiplus" _
    (ByVal brushMode As FillMode, ByRef path As Long) As Status

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

Private Declare Function GdipDeletePath Lib "gdiplus" _
    (ByVal path As Long) As Status

Private Declare Function GdipCreatePathGradientFromPath Lib _
    "gdiplus" (ByVal path As Long, _
    ByRef polyGradient As Long) As Status

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

Private Declare Function GdipFillPath Lib "gdiplus" _
    (ByVal graphics As Long, ByVal brush As Long, _
    ByVal path 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, _
    Optional ByRef lpOutput As Any) As Status

Private Declare Function GdipSetPathGradientCenterColor Lib _
    "gdiplus" (ByVal brush As Long, ByVal Color As Long) As Status

Private Declare Function GdipSetPathGradientCenterPointI Lib _
    "gdiplus" (ByVal brush As Long, _
    ByRef points As POINT) As Status

Private Declare Function LinearBlend Lib "gdiplus" Alias _
    "GdipSetPathGradientLinearBlend" (ByVal brush As Long, _
    ByVal focus As Single, ByVal sScale As Single) As Long

Private Declare Function SurroundColors Lib "gdiplus" Alias _
    "GdipSetPathGradientSurroundColorsWithCount" _
    (ByVal brush As Long, ByRef Colors As ARGB, _
    ByRef Count As Long) As Status

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

'------------------------------------------------------
' Funktion     : DrawStarPathGradient
' Beschreibung : Demo eines PathGradient
' Übergabewert : PicBox = PictureBox
'                CenterX = CenterpunktX der Centerfarbe
'                CenterY = CenterpunktY der Centerfarbe
'                LinearFocus = Wert: zwischen 0 und 1
'                LinearScale = Wert: zwischen 0 und 1
'------------------------------------------------------
Private Sub DrawStarPathGradient(ByVal PicBox As PictureBox, _
    ByVal CenterX As Long, ByVal CenterY As Long, _
    Optional ByVal LinearFocus As Single = 1, _
    Optional ByVal LinearScale As Single = 1)
    
    Dim lngPath As Long
    Dim lngGraphics As Long
    Dim lngBrush As Long
    Dim tPoints() As POINT
    Dim tCenterPoint As POINT
    Dim tColors() As ARGB
    Dim lngColorCount As Long
    
    ' Array zur Aufnahme der
    ' Pfadpunkte dimensionieren
    ReDim tPoints(0 To 15)
    
    ' Array zur Aufnahme der Farben
    ' für die Pfadpunkte dimensionieren
    ReDim tColors(0 To 15)
    
    lngColorCount = UBound(tColors) + 1
    
    ' Centerpunkt des Sternes
    tCenterPoint.X = CenterX
    tCenterPoint.Y = CenterY
    
    ' Pfadpunkte des Sternes festlegen
    tPoints(0).X = 130:  tPoints(0).Y = 0
    tPoints(1).X = 160:  tPoints(1).Y = 70
    tPoints(2).X = 220:  tPoints(2).Y = 40
    tPoints(3).X = 190:  tPoints(3).Y = 110
    tPoints(4).X = 260:  tPoints(4).Y = 130
    tPoints(5).X = 190:  tPoints(5).Y = 150
    tPoints(6).X = 220:  tPoints(6).Y = 220
    tPoints(7).X = 160:  tPoints(7).Y = 190
    tPoints(8).X = 130:  tPoints(8).Y = 260
    tPoints(9).X = 100:  tPoints(9).Y = 190
    tPoints(10).X = 40:  tPoints(10).Y = 220
    tPoints(11).X = 70:  tPoints(11).Y = 150
    tPoints(12).X = 0:   tPoints(12).Y = 130
    tPoints(13).X = 70:  tPoints(13).Y = 110
    tPoints(14).X = 40:  tPoints(14).Y = 40
    tPoints(15).X = 100: tPoints(15).Y = 70
    
    ' für jeden Pfadpunkt eine Farbe zuweisen
    ' schwarz opaque
    With tColors(0)
        .Alpha = 255
        .Red = 0
        .Green = 0
        .Blue = 0
    End With
    
    ' grün opaque
    With tColors(1)
        .Alpha = 255
        .Red = 0
        .Green = 255
        .Blue = 0
    End With
    
    ' blau opaque
    With tColors(2)
        .Alpha = 255
        .Red = 0
        .Green = 0
        .Blue = 255
    End With
    
    ' weiß opaque
    With tColors(3)
        .Alpha = 255
        .Red = 255
        .Green = 255
        .Blue = 255
    End With
    
    ' Farben für die anderen Pfadpunkte kopieren
    tColors(4) = tColors(0):  tColors(5) = tColors(1)
    tColors(6) = tColors(2):  tColors(7) = tColors(3)
    tColors(8) = tColors(0):  tColors(9) = tColors(1)
    tColors(10) = tColors(2): tColors(11) = tColors(3)
    tColors(12) = tColors(0): tColors(13) = tColors(1)
    tColors(14) = tColors(2): tColors(15) = tColors(3)
    
    ' Graphicsobjekt vom Hdc erstellen
    If Execute(GdipCreateFromHDC(PicBox.hDC, _
    lngGraphics)) = OK Then
        
        ' Pfadobjekt erstellen
        If Execute(GdipCreatePath(FillModeAlternate, _
        lngPath)) = OK Then
            
            ' Linien im Pfadobjekt erstellen
            If Execute(GdipAddPathLine2I(lngPath, _
            tPoints(0), UBound(tPoints) + 1)) = OK Then
                
                ' Brushobjekt vom Pfadobjekt erstellen
                If Execute(GdipCreatePathGradientFromPath( _
                lngPath, lngBrush)) = OK Then
                    
                    ' Centerfarbe vom Brushobjekt festlegen
                    ' (Rot opaque)
                    If Execute(GdipSetPathGradientCenterColor( _
                    lngBrush, &HFFFF0000)) = OK Then
                        
                        ' Centerpunkt vom Brushobjekt festlegen
                        If Execute(GdipSetPathGradientCenterPointI( _
                        lngBrush, tCenterPoint)) = OK Then
                            
                            ' Farben vom Brushobjekt an den
                            ' Punkten vom Pfadobjekt verteilen
                            If Execute(SurroundColors(lngBrush, _
                            tColors(0), lngColorCount)) = OK Then
                                
                                ' LinearBlend auf Brushobjekt
                                If Execute(LinearBlend(lngBrush, _
                                LinearFocus, LinearScale)) = OK Then
                                    
                                    ' Pfadobjekt mit Brushobjekt
                                    ' in das Graphicsobjekt zeichnen
                                    Call Execute(GdipFillPath( _
                                    lngGraphics, lngBrush, lngPath))
                                    
                                End If
                            End If
                        End If
                    End If
                    
                    ' Brushobjekt löschen
                    Call Execute(GdipDeleteBrush(lngBrush))
                End If
            End If
            
            ' Pfadobjekt löschen
            Call Execute(GdipDeletePath(lngPath))
        End If
        
        ' Graphicsobjekt löschen
        Call Execute(GdipDeleteGraphics(lngGraphics))
        
        ' PictureBox refreshen
        PicBox.Refresh
    End If
End Sub

'------------------------------------------------------
' 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 = Status.OK Then
        lCurErr = Status.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

'------------------------------------------------------
' Funktion     : UpdateScroll
' Beschreibung : Pfadgaradient zeichnen
'------------------------------------------------------
Private Sub UpdateScroll()
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Pfadgaradient zeichnen
        Call DrawStarPathGradient(picGradient, _
        hscCenterPoint(0).Value, hscCenterPoint(1).Value, _
        CSng(hscLinearBlend(0).Value / 10), _
        CSng(hscLinearBlend(1).Value / 10))
    End If
End Sub

'------------------------------------------------------
' Beschreibung : Form laden
'------------------------------------------------------
Private Sub Form_Load()
    GdipInitialized = False
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        
        ' diverse Controlparameter setzen
        With picGradient
            .AutoRedraw = True
            .BorderStyle = 0
            .Move 60, 60, ScaleX(260, vbPixels, vbTwips), _
            ScaleY(260, vbPixels, vbTwips)
        End With
        
        With hscCenterPoint(0)
            .Max = 260
            .Value = 130
        End With
        
        With hscCenterPoint(1)
            .Max = 260
            .Value = 130
        End With
        
        With hscLinearBlend(0)
            .Max = 10
            .Value = 5
        End With
        
        With hscLinearBlend(1)
            .Max = 10
            .Value = 10
        End With
        
        ' GDI+ ist gestartet
        GdipInitialized = True
        
        ' Pfadgaradient zeichnen
        Call UpdateScroll
        
    Else
        ' Initialisierung fehlgeschlagen
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
    
End Sub

'------------------------------------------------------
' Beschreibung : Form entladen
'------------------------------------------------------
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 hscCenterPoint_Change(Index As Integer)
    Call hscCenterPoint_Scroll(Index)
End Sub

Private Sub hscCenterPoint_Scroll(Index As Integer)
    Call UpdateScroll
End Sub

Private Sub hscLinearBlend_Change(Index As Integer)
    Call hscLinearBlend_Scroll(Index)
End Sub

Private Sub hscLinearBlend_Scroll(Index As Integer)
    Call UpdateScroll
End Sub
'--- Ende Formular "frmGdiPlusPathGradient" alias frmGdiPlusPathGradient.frm  ---
'-------- Ende Projektdatei GdiPlusPathGradient.vbp  --------