VBA Objekte ausrichten

[fremoikaner]

Hallo Koter,

so, nachdem ich jetzt wieder im Land bin ... habe ich das Makro noch dahingehend angepasst, dass es auch bei leerem Text einen Rahmen zeichnet. Das brauche ich dann, wenn der Name schon in der ursprünglichen Auswahl enthalten ist und ich nur einen Rahmen möchte. Das ganze sieht jetzt so aus:

Code:

Sub rechteck()
  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.03
  strName = ""
  strName = InputBox("Name: ", "Name eingeben oder Eingabe für keinen Namen", strName)
     
  Set sAw = ActiveSelectionRange.Group
  If strName = "" Then GoTo Rahmen
 
  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.SizeHeight Then
              sTxt.SizeWidth = sAw.SizeHeight
              sTxt.SizeHeight = sTxt.SizeHeight * sTxt.AbsoluteHScale
          End If
          sTxt.AlignToShape cdrAlignVCenter, sAw
          sTxt.PositionX = sAw.PositionX + Abstand + (sAw.SizeWidth + sTxt.SizeHeight) / 2
          sTxt.Rotate -90
  End If
  If sAw.Type = cdrGroupShape Then
      sTxt.OrderFrontOf sAw.Shapes(1)
  Else
      sAw.AddToSelection
      Set sAw = ActiveSelection.Group
  End If
Rahmen:
  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
  If strName = "" Then
   sAw.AddToSelection
   Set sAw = ActiveSelection.Group
  Else
   s2.OrderBackOf sAw.Shapes(sAw.Shapes.Count)
   End If
  ActiveDocument.EndCommandGroup
End Sub

Eine "Kleinigkeit" ist mir noch aufgefallen, die ich jedoch nicht mit dem Makro in Verbindund bringen kann:

Nach einmaligem Aufruf friert die Anzeige der x und y Position sowie der Höhe und Breite von Objekten ein. D.h. egal, was ich danach anklicke erhalte ich immer die gleiche Anzeige. Das lässt sich bislang nur durch einen Neustart von Corel wieder reaktivieren.

VG
fremoikaner