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

[fremoikaner]

kleiner Nachtrag ...

Ich habe vor
   ActiveDocument.EndCommandGroup
noch die Zeile
ActiveDocument.ReferencePoint = cdrTopLeft
eingefügt.
Seitdem friert die Anzeige nicht mehr ein und auch das Einfügen neuer Grafiken, oder dazukopieren funktioniert wieder regulär.

Gruß
Fremoikaner

[koter]

Hallo fremoikaner,

ich habe es mit 12/X4/X7 probiert, der Fehler trat nicht auf.
Ich wäre aber wohl auch nicht auf den ReferencePoint gekommen, wenn er aufgetreten wäre.

Vielen Dank für den „kleinen Nachtrag“!

Gruß

Koter