Ausrichten von Kurvenobjekten

[koter]

Hallo Boerni,

Du kannst es mit einem Makro versuchen:

Das Makro lässt horizontal angeordnete Objekte
in eine darunter liegende Strecke fallen,
ohne den Abstand zu ändern.

Die Streckenrichtung muss von links nach rechts zeigen,
sonst werden Die Objekte falsch herum angeordnet.

Das Makro richtet am Zentrum des Objekts aus.
Mit Text funktioniert das wegen der Schriftlinie nicht.

Du musst deshalb gleich hohe Rechtecke um Deine Objekte (Buchstaben) legen.

Dazu kannst Du das Makro HilfsrechteckeErstellen nutzen.
Die Rechtecke haben keinen Umriss und sind deshalb unsichtbar.

Mit dem Makro HilfsrechteckeEntfernen kannst Du diese später löschen.

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

Die von Gerrie vorgeschlagene Funktion gibt es ja in X6 noch nicht.
Sie würde Dir aber wegen der gleichmäßigen Abstände auch die Typografie versauen.

Gruß

Koter

P.S. Sehr akkurate Arbeit hast Du geleistet! Alles in Ebenen und jedes Objekt benannt. Respekt!