Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0672: Mit GDI+ ein Pfadobjekt per GdipWarpPath-Funktion manipulieren

VB 5/6-Tipp 0672: Mit GDI+ ein Pfadobjekt per GdipWarpPath-Funktion manipulieren

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipAddPathString, GdipClonePath, GdipCreateFontFamilyFromName, GdipCreateFromHDC, GdipCreatePath, GdipCreatePen1, GdipCreateSolidFill, GdipDeleteBrush, GdipDeleteFontFamily, GdipDeleteGraphics, GdipDeletePath, GdipDeletePen, GdipDeleteStringFormat, GdipDrawEllipse, GdipDrawPath, GdipFillPath, GdipGetPathWorldBoundsI, GdipSetSmoothingMode, GdipStringFormatGetGenericTypographic, GdipWarpPath, GdiplusShutdown, GdiplusStartup

Download: Download des Beispielprojektes [5,22 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 GDIPlusWarpPath.vbp  ---------
'--- Anfang Formular "frmGDIPlusWarpPath" alias frmGDIPlusWarpPath.frm  ---
Option Explicit

' ----==== GDI+ Konstanten ====----
Private Const FlatnessDefault As Single = 0.25
Private Const GdiPlusVersion As Long = 1&
Private Const QualityModeInvalid As Long = -1&
Private Const QualityModeDefault As Long = 0&
Private Const QualityModeLow As Long = 1&
Private Const QualityModeHigh As Long = 2&

' ----==== sonstige Konstanten ====----
Private Const CornerRadius As Long = 5&

' ----==== GDI+ Konstanten ====----
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

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

Private Type RECTF
    Left As Single
    Top As Single
    Right As Single
    Bottom As Single
End Type

Private Type POINTF
    X As Single
    Y As Single
End Type

' ----==== GDI+ Enums ====----
Private Enum FillMode
    FillModeAlternate = 0
    FillModeWinding = 1
End Enum

Private Enum FontStyle
    FontStyleRegular = 0
    FontStyleBold = 1
    FontStyleItalic = 2
    FontStyleBoldItalic = 3
    FontStyleUnderline = 4
    FontStyleStrikeout = 8
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

Private Enum SmoothingMode
    SmoothingModeInvalid = QualityModeInvalid
    SmoothingModeDefault = QualityModeDefault
    SmoothingModeHighSpeed = QualityModeLow
    SmoothingModeHighQuality = QualityModeHigh
    SmoothingModeNone = QualityModeHigh + 1
    SmoothingModeAntiAlias8x4 = QualityModeHigh + 2
    SmoothingModeAntiAlias = SmoothingModeAntiAlias8x4
    SmoothingModeAntiAlias8x8 = QualityModeHigh + 3
End Enum

Private Enum Unit
    UnitWorld = 0
    UnitDisplay = 1
    UnitPixel = 2
    UnitPoint = 3
    UnitInch = 4
    UnitDocument = 5
    UnitMillimeter = 6
End Enum

Private Enum WarpMode
    WarpModePerspective = 0
    WarpModeBilinear = 1
End Enum

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipAddPathString Lib "gdiplus" _
    (ByVal path As Long, ByVal sString As Long, _
    ByVal length As Long, ByVal family As Long, _
    ByVal style As FontStyle, ByVal emSize As Single, _
    ByRef layoutRect As RECTF, ByVal format As Long) As Status

Private Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" _
    (ByVal Name As Long, ByVal fontCollection As Long, _
    ByRef FontFamily 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 GdipCreatePen1 Lib "gdiplus" _
    (ByVal color As Long, ByVal Width As Single, _
    ByVal Unit As Unit, ByRef pen As Long) As Status

Private Declare Function GdipCreateSolidFill Lib "gdiplus" _
    (ByVal color As Long, ByRef brush As Long) As Status

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

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

Private Declare Function GdipDeleteFontFamily Lib "gdiplus" _
    (ByVal FontFamily As Long) As Status

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

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

Private Declare Function GdipDeletePen Lib "gdiplus" _
    (ByVal pen As Long) As Status

Private Declare Function GdipDeleteStringFormat Lib "gdiplus" _
    (ByVal format As Long) As Status

Private Declare Function GdipDrawEllipse Lib "gdiplus" _
    (ByVal graphics As Long, ByVal pen As Long, _
    ByVal X As Single, ByVal Y As Single, ByVal Width As Single, _
    ByVal Height As Single) As Status

Private Declare Function GdipDrawPath Lib "gdiplus" _
    (ByVal graphics As Long, ByVal pen As Long, _
    ByVal path 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 GdipGetPathWorldBoundsI Lib "gdiplus" _
    (ByVal path As Long, ByRef bounds As RECT, _
    ByVal matrix As Long, ByVal pen 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

Private Declare Function GdipSetSmoothingMode Lib "gdiplus" _
    (ByVal graphics As Long, _
    ByVal SmoothingMode As SmoothingMode) As Status

Private Declare Function GdipStringFormatGetGenericTypographic _
    Lib "gdiplus" (ByRef format As Long) As Status

Private Declare Function GdipWarpPath Lib "gdiplus" _
    (ByVal path As Long, ByVal matrix As Long, _
    ByRef points As POINTF, ByVal Count As Long, _
    ByVal srcx As Single, ByVal srcy As Single, _
    ByVal srcwidth As Single, ByVal srcheight As Single, _
    ByVal WarpMode As WarpMode, ByVal flatness As Single) As Status

' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private sFontName As String
Private sString As String
Private lPath As Long
Private lFontFamily As Long
Private lFontFormat As Long
Private tRect As RECT
Private tRectF As RECTF
Private tCorners() As POINTF
Private DragCorner As Long

'------------------------------------------------------
' 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     : WarpPath
' Beschreibung : Ein Pfadobjekt verändern
'------------------------------------------------------
Private Sub WarpPath()
    
    Dim lGraphics As Long
    Dim lBrush As Long
    Dim lPen As Long
    Dim lPen1 As Long
    Dim lClonePath As Long
    Dim i As Long
    
    Me.Cls
    
    ' Pathobjekt clonen,
    ' damit das Original-Pathobjekt nicht verändert wird
    If Execute(GdipClonePath(lPath, _
    lClonePath)) = OK Then
        
        ' Graphicsobjekt vom Hdc erstellen
        If Execute(GdipCreateFromHDC(Me.hDC, _
        lGraphics)) = OK Then
            
            ' Smoothingmode für Graphicsobjekt setzen
            If Execute(GdipSetSmoothingMode(lGraphics, _
            SmoothingModeHighQuality)) = OK Then
                
                ' Manipulation des Pathobjektes
                Call Execute(GdipWarpPath(lClonePath, 0, _
                tCorners(0), UBound(tCorners) + 1, _
                tRect.Left, tRect.Top, tRect.Right, _
                tRect.Bottom, WarpModePerspective, _
                FlatnessDefault))
                
                ' Brushobjekt erstellen
                ' Füllfarbe für das Pfadobjekt
                If Execute(GdipCreateSolidFill(&HFF128080, _
                lBrush)) = OK Then
                    
                    ' Penobjekt erstellen
                    ' Randfarbe für das Pfadobjekt
                    If Execute(GdipCreatePen1(&HFF000000, 1, _
                    UnitPixel, lPen)) = OK Then
                        
                        ' Penobjekt erstellen
                        ' Farbe für die Ziehecken
                        If Execute(GdipCreatePen1(&HFFFF00FF, 1, _
                        UnitPixel, lPen1)) = OK Then
                            
                            ' Pfad mit Brush füllen
                            Call Execute(GdipFillPath(lGraphics, _
                            lBrush, lClonePath))
                            
                            ' Pfad mit Pen zeichnen
                            Call Execute(GdipDrawPath(lGraphics, _
                            lPen, lClonePath))
                            
                            ' Ecken des Pathobjektes zeichen
                            For i = 0 To 3
                                Call Execute(GdipDrawEllipse( _
                                lGraphics, lPen1, _
                                tCorners(i).X - CornerRadius, _
                                tCorners(i).Y - CornerRadius, _
                                CornerRadius * 2, CornerRadius * 2))
                            Next i
                            
                            ' Penobjekt löschen
                            Call Execute(GdipDeletePen(lPen1))
                        End If
                        
                        ' Penobjekt löschen
                        Call Execute(GdipDeletePen(lPen))
                    End If
                    
                    ' Brushobjekt löschen
                    Call Execute(GdipDeleteBrush(lBrush))
                End If
            End If
            
            ' lösche Graphicsobjekt
            Call Execute(GdipDeleteGraphics(lGraphics))
        End If
        
        ' geclontes Pathobjekt löschen
        Call Execute(GdipDeletePath(lClonePath))
    End If
    Me.Refresh
End Sub

Private Sub Form_Load()
    GdipInitialized = False
    Me.ScaleMode = vbPixels
    Me.AutoRedraw = True
    
    ' Eckenindex -1 = keine Ecke ausgewählt
    DragCorner = -1
    
    ' muss ein TrueType oder OpenType-Font sein
    sFontName = "Arial"
    
    ' String für Pfadobjekt
    sString = "ActiveVB"
    
    ' GDI+ starten
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' Pfadobjekt erstellen
        If Execute(GdipCreatePath(FillModeAlternate, _
        lPath)) = OK Then
            
            ' Fontfamilyobjekt erstellen
            If Execute(GdipCreateFontFamilyFromName( _
            StrPtr(sFontName), 0, lFontFamily)) = OK Then
                
                ' Fontformatobjekt erstellen
                If Execute(GdipStringFormatGetGenericTypographic _
                (lFontFormat)) = OK Then
                    
                    ' Stringpfadobjekt zum Pfadobjekt hinzufügen
                    If Execute(GdipAddPathString(lPath, _
                    StrPtr(sString), Len(sString), _
                    lFontFamily, FontStyleBold, 100, _
                    tRectF, lFontFormat)) = OK Then
                        
                        ' Größe des Pfadobjektes auslesen
                        If Execute(GdipGetPathWorldBoundsI(lPath, _
                        tRect, 0, 0)) = OK Then
                            
                            ReDim tCorners(0 To 3)
                            
                            ' Ecke oben links
                            tCorners(0).X = tRect.Left
                            tCorners(0).Y = tRect.Top
                            
                            ' Ecke oben rechts
                            tCorners(1).X = tRect.Right
                            tCorners(1).Y = tRect.Top
                            
                            ' Ecke unten links
                            tCorners(2).X = tRect.Left
                            tCorners(2).Y = tRect.Bottom
                            
                            ' Ecke unten rechts
                            tCorners(3).X = tRect.Right
                            tCorners(3).Y = tRect.Bottom
                            
                            ' Pfad verzerren
                            Call WarpPath
                            
                        End If
                    End If
                End If
            End If
        End If
        
    Else
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
End Sub

Private Sub Form_MouseDown(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    
    Dim i As Long
    
    ' welche Ecke wird verändert
    For i = 0 To 3
        If Abs(tCorners(i).X - X) < CornerRadius And _
        Abs(tCorners(i).Y - Y) < CornerRadius Then
            ' EckenIndex setzen
            DragCorner = i
            Exit For
        End If
    Next i
End Sub

Private Sub Form_MouseMove(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    
    Dim i As Long
    
    ' über welcher Ecke befindet sich der Mauszeiger
    ' und Mauszeiger ändern wenn DragCorner >= 0
    For i = 0 To 3
        If Abs(tCorners(i).X - X) < CornerRadius And _
        Abs(tCorners(i).Y - Y) < CornerRadius Then
            If Me.MousePointer <> 15 Then Me.MousePointer = 15
            Exit For
        Else
            'ist DragCorner < 0 dann MousePointer = 0
            If DragCorner < 0 Then
                If Me.MousePointer <> 0 Then Me.MousePointer = 0
            End If
        End If
    Next i
    
    ' wenn der Mauszeiger sich über keiner Ecke befindet
    ' und DragCorner < 0 dann Sub verlassen
    If DragCorner < 0 Then Exit Sub
    
    ' X-Position der entsprechenden Ecke speichern
    tCorners(DragCorner).X = X
    If tCorners(DragCorner).X < 0 Then
        tCorners(DragCorner).X = 0
        ElseIf tCorners(DragCorner).X > Me.ScaleWidth Then
        tCorners(DragCorner).X = Me.ScaleWidth
    End If
    
    ' Y-Position der entsprechenden Ecke speichern
    tCorners(DragCorner).Y = Y
    If tCorners(DragCorner).Y < 0 Then
        tCorners(DragCorner).Y = 0
        ElseIf tCorners(DragCorner).Y > Me.ScaleHeight Then
        tCorners(DragCorner).X = Me.ScaleHeight
    End If
    
    ' Pfad verzerren
    Call WarpPath

End Sub

Private Sub Form_MouseUp(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    
    ' Eckenindex -1 = keine Ecke ausgewählt
    DragCorner = -1
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Fontfamilyobjekt löschen
        If lFontFamily Then _
        Call Execute(GdipDeleteFontFamily(lFontFamily))
        
        ' Fontformatobjekt löschen
        If lFontFormat Then _
        Call Execute(GdipDeleteStringFormat(lFontFormat))
        
        ' Pathobjekt löschen
        If lPath Then Call Execute(GdipDeletePath(lPath))
        
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub
'--- Ende Formular "frmGDIPlusWarpPath" alias frmGDIPlusWarpPath.frm  ---
'---------- Ende Projektdatei GDIPlusWarpPath.vbp  ----------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.