Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0684: Mit GDI+ ein Bild perspektivisch verändern

VB 5/6-Tipp 0684: Mit GDI+ ein Bild perspektivisch verändern

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipCreateBitmapFromHBITMAP, GdipCreateFromHDC, GdipCreatePen1, GdipDeleteGraphics, GdipDeletePen, GdipDisposeImage, GdipDrawEllipse, GdipDrawImagePointsRect, GdipGetImageBounds, GdiplusShutdown, GdiplusStartup

Download: Download des Beispielprojektes [52 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 GDIPlusWarpImage.vbp ---------
'--- Anfang Formular "frmGDIPlusWarpImage" alias frmGDIPlusWarpImage.frm  ---

Option Explicit

' ----==== GDIPlus Konstanten ====----
Private Const GdiPlusVersion As Long = 1&

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

' ----==== GDIPlus 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

' ----==== sonstige Typen ====----
Private Type POINTF
    X As Single
    Y As Single
End Type

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

' ----==== GDIPlus Enumerationen ====----
Private Enum Unit
    UnitWorld = 0
    UnitDisplay = 1
    UnitPixel = 2
    UnitPoint = 3
    UnitInch = 4
    UnitDocument = 5
    UnitMillimeter = 6
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 Deklarationen ====----
Private Declare Function GdipCreateBitmapFromHBITMAP _
    Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, _
    ByRef bitmap As Long) As Status

Private Declare Function GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hDC As Long, ByRef graphics 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 GdipDeleteGraphics Lib "gdiplus" _
    (ByVal graphics As Long) As Status

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

Private Declare Function GdipDisposeImage Lib "gdiplus" _
    (ByVal image 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 GdipDrawImagePointsRect Lib "gdiplus" _
    (ByVal graphics As Long, ByVal image As Long, _
    ByRef dstPoints As POINTF, ByVal Count As Long, _
    ByVal srcx As Single, ByVal srcy As Single, _
    ByVal srcwidth As Single, ByVal srcheight As Single, _
    ByVal srcUnit As Unit, ByVal imageAttributes As Long, _
    ByVal callback As Long, ByVal callbackData As Long) As Status

Private Declare Function GdipGetImageBounds Lib "gdiplus" _
    (ByVal image As Long, ByRef srcRect As RECTF, _
    ByRef srcUnit As Unit) 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
Private lBitmap As Long
Private lDragCorner As Long
Private tBitmapRectF As RECTF
Private tCorners() As POINTF
Private oPicture As StdPicture

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

'------------------------------------------------------
' Funktion     : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
'------------------------------------------------------
Private Function GdiErrorString(ByVal eError As Status) As String
    Dim s As String
    
    Select Case eError
    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     : WarpImage
' Beschreibung : Ein GDI+ Bitmapobjekt perspektivisch verändern
'------------------------------------------------------
Private Sub WarpImage()
    
    Dim i As Long
    Dim lPen As Long
    Dim lGraphics As Long
    
    Me.Cls
    
    ' Graphicsobjekt vom Hdc erstellen -> lGraphics
    If Execute(GdipCreateFromHDC(Me.hDC, _
    lGraphics)) = OK Then
        
        ' Penobjekt erstellen -> lPen
        ' Farbe für die Ziehecken
        If Execute(GdipCreatePen1(&HFFFFFF00, 1, _
        UnitPixel, lPen)) = OK Then
            
            ' zeichnet das Bitmapobjekt lBitmap in das
            ' Graphicsobjekt lGraphics an den entsprechenden
            ' Eckpunkten tCorners in der entsprechenden Größe
            ' tBitmapRectF
            If Execute(GdipDrawImagePointsRect(lGraphics, _
            lBitmap, tCorners(0), UBound(tCorners) + 1, _
            tBitmapRectF.Left, tBitmapRectF.Top, _
            tBitmapRectF.Right, tBitmapRectF.Bottom, _
            UnitPixel, 0, 0, 0)) = OK Then
                
                ' Ecken zeichnen
                For i = 0 To 2
                    Call Execute(GdipDrawEllipse(lGraphics, lPen, _
                    tCorners(i).X - CornerRadius, _
                    tCorners(i).Y - CornerRadius, _
                    CornerRadius * 2, CornerRadius * 2))
                Next i
            End If
            
            ' Penobjekt löschen
            Call Execute(GdipDeletePen(lPen))
        End If
        
        ' Graphicsobjekt löschen
        Call Execute(GdipDeleteGraphics(lGraphics))
    End If
    
    Me.Refresh
End Sub

Private Sub Form_Load()
    
    Dim sAppPath As String
    Dim sTestPicture As String
    
    GdipInitialized = False
    
    ' Eckenindex -1 = keine Ecke ausgewählt
    lDragCorner = -1
    
    ' Bilddatei
    sTestPicture = "test.jpg"
    
    ' Parameter für die Form setzen
    With Me
        .Height = 9000
        .Width = 9000
        .ScaleMode = vbPixels
        .AutoRedraw = True
    End With
    
    ' Pfad der Anwendung ermitteln
    sAppPath = App.Path
    
    ' Backslash am Pfad anfügen, falls nicht vorhanden
    If Right$(sAppPath, 1) <> "\" Then sAppPath = sAppPath & "\"
    
    ' Laden der Bilddatei
    Set oPicture = LoadPicture(sAppPath & sTestPicture)
    
    ' GDI+ starten
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' Bitmapobjekt vom Handle erstellen -> lBitmap
        If Execute(GdipCreateBitmapFromHBITMAP(oPicture.Handle, _
        0, lBitmap)) = OK Then
            
            ' Größe des Bitmapobjektes auslesen
            If Execute(GdipGetImageBounds(lBitmap, tBitmapRectF, _
            UnitPixel)) = OK Then
                
                ReDim tCorners(0 To 2)
                
                ' Ecke oben links
                tCorners(0).X = (Me.ScaleWidth \ 2) - _
                (tBitmapRectF.Right \ 2)
                tCorners(0).Y = (Me.ScaleHeight \ 2) - _
                (tBitmapRectF.Bottom \ 2)
                
                ' Ecke oben rechts
                tCorners(1).X = (Me.ScaleWidth \ 2) + _
                (tBitmapRectF.Right \ 2)
                tCorners(1).Y = tCorners(0).Y
                
                ' Ecke unten links
                tCorners(2).X = tCorners(0).X
                tCorners(2).Y = (Me.ScaleHeight \ 2) + _
                (tBitmapRectF.Bottom \ 2)
                
                ' Ecke unten rechts
                ' wird durch GDI+ berechnet
                
                ' Bitmapobjekt perspektivisch verändern
                Call WarpImage
            End If
            
        End If
        
    Else
        ' initialisieren fehlgeschlagen
        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 2
        If Abs(tCorners(i).X - X) < CornerRadius And _
        Abs(tCorners(i).Y - Y) < CornerRadius Then
            ' EckenIndex setzen
            lDragCorner = 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 lDragCorner >= 0
    For i = 0 To 2
        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 lDragCorner < 0 dann MousePointer = 0
            If lDragCorner < 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 lDragCorner < 0 dann Sub verlassen
    If lDragCorner < 0 Then Exit Sub
    
    ' X-Position der entsprechenden Ecke speichern
    tCorners(lDragCorner).X = X
    If tCorners(lDragCorner).X < 0 Then
        tCorners(lDragCorner).X = 0
        ElseIf tCorners(lDragCorner).X > Me.ScaleWidth Then
        tCorners(lDragCorner).X = Me.ScaleWidth
    End If
    
    ' Y-Position der entsprechenden Ecke speichern
    tCorners(lDragCorner).Y = Y
    If tCorners(lDragCorner).Y < 0 Then
        tCorners(lDragCorner).Y = 0
        ElseIf tCorners(lDragCorner).Y > Me.ScaleHeight Then
        tCorners(lDragCorner).X = Me.ScaleHeight
    End If
    
    ' Bitmapobjekt perspektivisch verändern
    Call WarpImage
End Sub

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

Private Sub Form_Unload(Cancel As Integer)
    
    ' StdPicture Objekt löschen
    Set oPicture = Nothing
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Bitmapobjekt lBitmap löschen
        If lBitmap Then Call Execute(GdipDisposeImage(lBitmap))
        
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub
'--- Ende Formular "frmGDIPlusWarpImage" alias frmGDIPlusWarpImage.frm  ---
'---------- Ende Projektdatei GDIPlusWarpImage.vbp ----------