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!