Verzerrung von Rechtecken

Code:
Sub start()

    Dim sel As ShapeRange

    Dim Bitmap As Shape, Kurve As Shape

    

    Set sel = ActiveSelectionRange

    If sel.Shapes.Count = 2 Then

        If sel.Shapes(1).Type = cdrBitmapShape And sel.Shapes(2).Type = cdrCurveShape And sel.Shapes(2).DisplayCurve.Nodes.Count = 4 Then

            Set Bitmap = sel.Shapes(1)

            Set Kurve = sel.Shapes(2)

            Call Verzerren(Kurve, Bitmap)

        ElseIf sel.Shapes(2).Type = cdrBitmapShape And sel.Shapes(1).Type = cdrCurveShape And sel.Shapes(1).DisplayCurve.Nodes.Count = 4 Then

            Set Bitmap = sel.Shapes(2)

            Set Kurve = sel.Shapes(1)

            Call Verzerren(Kurve, Bitmap)

        Else

            MsgBox "Bitte eine Kurve und eine Bitmap auswählen!", vbCritical, "Fehler!"

        End If

    Else

    MsgBox "Bitte eine Kurve und eine Bitmap auswählen!", vbCritical, "Fehler!"

    End If

End Sub



Sub Verzerren(Kurve As Shape, Bitmap As Shape)

    Dim ImpBitmap As Shape

    Dim appPaint As New PHOTOPAINT.Application

    Dim filter As ExportFilter

    Dim docPP As PHOTOPAINT.Document

    Dim BBKurve As Rect

    Dim Randzugabe As Integer

    Dim UDP As String

    Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long, x3 As Long, y3 As Long, x4 As Long, y4 As Long

    

    UDP = Application.UserDataPath

    u = ActiveDocument.Unit

    Set BBKurve = Kurve.BoundingBox

    

    x1 = Round(ConvertUnits(Kurve.Curve.Nodes(1).PositionX, u, cdrPixel) - ConvertUnits(BBKurve.Left, u, cdrPixel), 0)

    y1 = Round(ConvertUnits(BBKurve.Top, u, cdrPixel) - ConvertUnits(Kurve.Curve.Nodes(1).PositionY, u, cdrPixel), 0)

    x2 = Round(ConvertUnits(Kurve.Curve.Nodes(2).PositionX, u, cdrPixel) - ConvertUnits(BBKurve.Left, u, cdrPixel), 0)

    y2 = Round(ConvertUnits(BBKurve.Top, u, cdrPixel) - ConvertUnits(Kurve.Curve.Nodes(2).PositionY, u, cdrPixel), 0)

    x3 = Round(ConvertUnits(Kurve.Curve.Nodes(3).PositionX, u, cdrPixel) - ConvertUnits(BBKurve.Left, u, cdrPixel), 0)

    y3 = Round(ConvertUnits(BBKurve.Top, u, cdrPixel) - ConvertUnits(Kurve.Curve.Nodes(3).PositionY, u, cdrPixel), 0)

    x4 = Round(ConvertUnits(Kurve.Curve.Nodes(4).PositionX, u, cdrPixel) - ConvertUnits(BBKurve.Left, u, cdrPixel), 0)

    y4 = Round(ConvertUnits(BBKurve.Top, u, cdrPixel) - ConvertUnits(Kurve.Curve.Nodes(4).PositionY, u, cdrPixel), 0)

    

    ActiveDocument.BeginCommandGroup "Verzerren"

    

    Bitmap.Copy

    Set docPP = appPaint.CreateDocumentFromClipboard

    

    With docPP

        .Resample _

         ConvertUnits(Kurve.SizeWidth, ActiveDocument.Unit, cdrPixel), _

         ConvertUnits(Kurve.SizeHeight, ActiveDocument.Unit, cdrPixel), True

        .Mask.SelectAll

        .ActiveLayer.Distort x1, y1, x2, y2, x3, y3, x4, y4, True

        .SaveAs(UDP & "~temp.jpg", cdrJPEG).Finish

        .Close

    End With

    ActiveLayer.Import UDP & "~temp.jpg"

    Set ImpBitmap = ActiveSelection

    

    With ImpBitmap

        .SizeWidth = Kurve.SizeWidth

        .SizeHeight = Kurve.SizeHeight

        .Flip cdrFlipVertical

        .AddToPowerClip Kurve, cdrTrue

    End With

    

    ActiveDocument.EndCommandGroup

    

    Kill UDP & "~temp.jpg"

End Sub