VBA Objekte ausrichten

[koter]

Hallo Fremoikaner,

ich habe Deinen Code verändert und die Anzahl der Variablen reduziert:

Code:

Sub rechteck2()
   Dim Abstand As Double
   Dim sTxt As New Shape, s2 As Shape, sAw As Shape
   Dim strName As String
   
   If ActiveSelection.Shapes.Count = 0 Then Exit Sub
   ActiveDocument.BeginCommandGroup "Beschriften"
   
   ActiveDocument.ReferencePoint = cdrCenter
   Abstand = 0.05
   strName = "Beschriftung"
   strName = InputBox("Name: ", "Name eingeben oder Eingabe für keinen Namen", strName)
   If strName = "" Then Exit Sub
   
   Set sAw = ActiveSelectionRange.Group
   Set sTxt = ActiveLayer.CreateArtisticText(0, 0, strName)
   With sTxt.Text.Story
       .Font = "1451_Eng_DB"
'        .Font = "DIN 1451 Engschrift"
       .Alignment = cdrCenterAlignment
       .Size = 8
   End With
   
   If sAw.SizeWidth > sAw.SizeHeight Then
       If sTxt.SizeWidth > sAw.SizeWidth Then
           sTxt.SizeWidth = sAw.SizeWidth
           sTxt.SizeHeight = sTxt.SizeHeight * sTxt.AbsoluteHScale
       End If
       sTxt.AlignToShape cdrAlignHCenter, sAw
       sTxt.PositionY = Abstand + sAw.PositionY + (sAw.SizeHeight + sTxt.SizeHeight) / 2
   Else ' Text drehen
       If sTxt.SizeWidth > sAw.SizeWidth Then
           sTxt.SizeWidth = sAw.SizeHeight
           sTxt.SizeHeight = sTxt.SizeHeight * sTxt.AbsoluteHScale
       End If
       With sTxt
       sTxt.AlignToShape cdrAlignVCenter, sAw
       sTxt.PositionX = sAw.PositionX - Abstand - (sAw.SizeWidth + sTxt.SizeHeight) / 2
       sTxt.Rotate 90
       End With
   End If
   
   If sAw.Type = cdrGroupShape Then
       sTxt.OrderFrontOf sAw.Shapes(1)
   Else
       sAw.AddToSelection
       Set sAw = ActiveSelection.Group
   End If
   
   ActiveDocument.ReferencePoint = cdrBottomLeft
   Set s2 = ActiveLayer.CreateRectangle2(sAw.PositionX - Abstand, sAw.PositionY - Abstand, _
   sAw.SizeWidth + Abstand * 2, sAw.SizeHeight + Abstand * 2)
   ActiveDocument.ReferencePoint = cdrCenter
   
   s2.Outline.Color.CMYKAssign 0, 0, 0, 100
   s2.OrderBackOf sAw.Shapes(sAw.Shapes.Count)
   
   ActiveDocument.EndCommandGroup
End Sub

Ich habe auf die BoundingBox und einen expliziten ShapeRange verzichtet.

Wenn ich Deine Beschreibung richtig verstanden habe, sollte es so auch mit X3 funktionieren.
(ich habe X3 nicht, kann es also leider nicht testen)

Gruß

Koter