VBA Objekte ausrichten

[fremoikaner]

Hallo Koter,

Danke nochmal für den weiteren Lösungsansatz.
Leider klappt es so nicht, da vorher noch etwas passiert, was ich beim ersten Mal nicht erwähnt hatte.
Ist der Text nämlich zu lang (also länger, als die ShapeRange, die markiert war), wird der Text automatisch verkleinert, so dass er maximal so breit ist wie die ShapeRange.

Ich kopiere mal etwas mehr von meinem Makro hierein - alles überflüssige habe ich entfernt:

Code:

Sub rechteck()

Dim x As Double, y As Double, w As Double, h As Double, x1 As Double, y1 As Double, w1 As Double, h1 As Double
Dim sr As ShapeRange, sr2 As ShapeRange
Dim s1, s2 As Shape
Dim srNewShapes As New ShapeRange
Dim name As String
Dim OrigSelection As ShapeRange

If ActiveSelection.Shapes.Count = 0 Then Exit Sub
Set sr = ActiveSelectionRange

name = ""
name = InputBox("Name: ", "Name eingeben oder Eingabe für keinen Namen")

   sr.GetBoundingBox x, y, w, h, True
   sr.CreateSelection
   sr.Group
       
   If h < w Then
       Set s1 = ActiveLayer.CreateArtisticText(x + w + 0.05, y + (h / 2) + 0.05, name, , , "1451_Eng_DB", 8, , , , cdrCenterAlignment)
       s1.Rotate (270)
       s1.GetBoundingBox x1, y1, w1, h1, True 'Maße vom Text
       If h1 > h Then
           s1.SetSize , (h)
       End If
       
       sr.AlignToShape cdrAlignVCenter, ActiveLayer.Shapes(ActiveSelection.Shapes.Count), cdrTextAlignBoundingBox
   Else
       Set s1 = ActiveLayer.CreateArtisticText(x + (w / 2) - 0.025, y + h + 0.02, name, , , "1451_Eng_DB", 8, , , , cdrCenterAlignment)
       's1.CenterX = sr.CenterX
       
       s1.GetBoundingBox x1, y1, w1, h1, True 'Maße vom Text
       If w1 > w Then
           s1.SetSize (w)
       End If
   End If
   s1.Fill.UniformColor.CMYKAssign 100, 100, 0, 0
   
   s1.OrderToBack
   s1.Selected = True
   srNewShapes.Add s1
       
   sr.AddRange srNewShapes
   sr.CreateSelection
       
   sr.GetBoundingBox x, y, w, h, True
   sr.CreateSelection
   Set s2 = ActiveLayer.CreateRectangle2(x - 0.025, y - 0.025, w + 0.05, h + 0.05)
   s2.Fill.ApplyNoFill
   s2.Outline.Color.CMYKAssign 0, 0, 0, 100
   s2.OrderToBack
   s2.Selected = True
   srNewShapes.Add s2

sr.AddRange srNewShapes
sr.CreateSelection
sr.Group

sr.RemoveFromSelection
Set sr = ActiveSelection.Shapes.All

End Sub

Prinzipiell prüft das Makro, welches die kürzere Seite ist (Höhe oder Breite) und ergänzt dann die ShapeRange durch einen Namen an der kürzeren Seite (oben oder rechts) sowie einem Rahmen um ShapeRange+Name.

Ist der Name länger, wird er entsprechend verkleinert. Dabei bleibt er jedoch an Ort und Stelle (also z.B. links vom Objekt). Somit würde er beim Rechteck dann *dort* mit aufgenommen werden. Er soll aber zentriert über der ShapeRange stehen (oder eben rechts daneben).
Die ShapeRange kann zwischen 1 und n Objekten beinhalten; auch können auf der aktiven Seite auch andere Objekte sein, die nicht zur ShapeRange gehören - von daher funktioniert der Befehl "ActivePage.Shapes.All" leider nicht ...
So habe ich es nämlich bei einem ähnlich gelagerten Fall gelöst.

Gruß
fremoikaner