Ausrichten von Kurvenobjekten

Code:
Sub InStreckeFallen()

    Dim Objekte As ShapeRange

    Dim Strecke As Shape, objAR As Shape, HLM As New Shape, HLM2 As New Shape, E As New Shape

    Dim seg As Segment

    Dim Pfad As SubPath

    Dim x As Double, y As Double, p As Double, t As Double

    Dim cps As CrossPoints, cp As CrossPoint

    On Error GoTo fehler

    ActiveDocument.Unit = cdrMillimeter

    Set Objekte = ActiveSelectionRange

    Objekte.Sort "@shape1.Left < @shape2.Left"

    Objekte.Sort "@shape1.Top > @shape2.Top"

    Set Strecke = Objekte.Shapes.Last

    If Strecke.Type <> cdrCurveShape Then

        MsgBox "Strecke muss eine Kurve sein!", vbCritical, "Fehler"

        Exit Sub

    End If

    Objekte.Remove Objekte.Shapes.Count

    Set Pfad = Strecke.Curve.SubPaths.First

    ActiveDocument.BeginCommandGroup "auf Strecke"

    Optimization = True

    For Each objAR In Objekte

        Set HLM = ActiveLayer.CreateLineSegment(objAR.CenterX, objAR.CenterY, objAR.CenterX, Strecke.BottomY - 2)

        Set cps = Pfad.GetIntersections(HLM.Curve.SubPaths.First, cdrAbsoluteSegmentOffset)

        HLM.Delete

        Pfad.GetPointPositionAt x, y, cps(1).Offset, cdrAbsoluteSegmentOffset

        Set E = ActiveLayer.CreateEllipse2(x, y, objAR.SizeWidth / 2)

        E.ConvertToCurves

        Set cps = Pfad.GetIntersections(E.Curve.SubPaths.First, cdrAbsoluteSegmentOffset)

        Set HLM2 = ActiveLayer.CreateLineSegment(cps(1).PositionX, cps(1).PositionY, cps(2).PositionX, cps(2).PositionY)

        Set seg = HLM2.Curve.SubPaths.First.Segments.First

        objAR.CenterX = x

        objAR.CenterY = y

        objAR.RotationAngle = seg.StartingControlPointAngle

        E.Delete

        HLM2.Delete

    Next

fehler:

    Optimization = False

    ActiveDocument.EndCommandGroup

    Refresh

End Sub



Sub HilfsrechteckeErstellen()

    Dim Objekte As ShapeRange, RGruppe As New ShapeRange

    Dim RoB As Shape, obj As Shape, RG As Shape

    Dim z As Integer

    ActiveDocument.Unit = cdrMillimeter

    Set Objekte = ActiveSelectionRange

    Debug.Print Objekte.SizeHeight

    ActiveDocument.BeginCommandGroup "Rechtecke erstellen"

    For Each obj In Objekte

        Set RoB = ActiveLayer.CreateRectangle(obj.LeftX, Objekte.TopY, obj.RightX, Objekte.BottomY)

        RoB.Outline.Width = 0

        RoB.Name = "Ausrichtungshilfsrechteck"

        RGruppe.Add RoB

        RGruppe.Add obj

        Set RG = RGruppe.Group

        Set RGruppe = Nothing

    Next

    ActiveDocument.EndCommandGroup

End Sub



Sub HilfsrechteckeEntfernen()

    Dim ARH As ShapeRange

    Dim R As Shape

    Set ARH = ActivePage.FindShapes("Ausrichtungshilfsrechteck")

    For Each R In ARH

         R.ParentGroup.Ungroup

    Next

    ARH.Delete

End Sub