VBA Objekte ausrichten

[fremoikaner]

Hallo Koter,

fast ... ;-)

Ich habe noch für s2 ein "nofill" eingebaut, da ich ansonsten ein schwarzes Rechteck hätte.
Außerdem den Text noch blau einfärben:
sTxt.Text.Story.Fill.UniformColor.CMYKAssign 100, 100, 0, 0

Ich poste den neuen Code mal hier, falls sowas nochmal jemand brauchen kann:

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
  sTxt.Text.Story.Fill.UniformColor.CMYKAssign 100, 100, 0, 0
 
  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.Fill.ApplyNoFill
  s2.OrderBackOf sAw.Shapes(sAw.Shapes.Count)
 
  ActiveDocument.EndCommandGroup
End Sub

Allerdings habe ich mich jetzt doch entschieden, mit meiner Version weiterzumachen, da noch einige Elemente enthalten sind (deshalb auch die vielen weiteren Variablen), die jedoch für die Grundfunktion "Text ausrichten" nicht relevant waren.
Mir ist nämlich die Idee gekommen, mein
s1.size durch s1.stretch (w/w1) bzw. s1.stretch (h/h1) zu ersetzen. Dabei bleibt der neue Text an der gleichen Stelle und wird über die Mitte neu skaliert. Damit klappt dann alles.
Habe es mit allen 4 Varianten (senkrecht/waagrecht; langer Text, kurzer Text) probiert - funzt :-)

Wenn ich Dir ein Bier oder auch 2 ausgeben darf, lass' mich bitte wissen wie ...
Vielen Dank für Dein Engagement!

Gruß
fremoikaner