Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Dieses Beispiel zeigt, wie mittels GDI+ ein Bild perspektivisch verändert werden kann. Dazu sind einfach die drei Eckpunkte zu verschieben.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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

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.