Verzerrung von Rechtecken

[koter]

Hallo Sabine,

...du kannts ein Bitmap in Draw nicht verzerren. (erst ab Suite 2018 mit der Funktion Hülle)...

wenn es sich nur um ein Rechteck (genauer: eine Kurve mit 4 Knoten) handelt, kannst du vielleicht ein Makro in Deinen Arbeitsablauf einbauen, welches PP für die Verzerrung verwendet:

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

Das Makro verwendet die Zwischenablage. Dort sollten also keine wichtigen Daten liegen!
(getestet mit X4)

Gruß

Koter