VBA Objekte ausrichten

[fremoikaner]

Hallo zusammen!

Ich möchte gerne in VBA einen Text erzeugen (das klappt soweit) und diesen zentriert über den vorher markierten Shapes ausrichten.
Die markierten Shapes sind als ShapeRange der Variable sr zugewiesen, mein neu erstellter Text als s1 (Shape).
Irgendjemand eine Idee?

Viele Grüße
fremoikaner

[koter]

Hallo fremoikaner,
willkommen im Forum!

Ich gehe von einer horizontalen Ausrichtung aus.
Der Befehl lauten dann:

s1.CenterX = sr.CenterX

Gruß

Koter

[fremoikaner]

Hallo Koter,

Danke für die schnelle Antwort - noch dazu am Feiertag ;-)

Ja, diesen Befehl hatte ich hier im Forum bei einem ähnlichen Problem schon gefunden und (leider erfolglos probiert).
Ich erhalte einen Laufzeitfehler 438; Objekt unterstützt diese Eigenschaft oder Methode nicht.
Auch beim Eingeben erhalte ich nach sr. den Befehl "CenterX" nicht angeboten.

Die Zeile davor (die den Text erstellt) lautet:

Code:

Set s1 = ActiveLayer.CreateArtisticText(x + (w / 2) - 0.025, y + h + 0.02, name, , , "1451_Eng_DB", 8, , , , cdrCenterAlignment)

Die Variablen x, y, w und h sind die "boundingbox" der vorher markierten ShapeRange.
Der Text wird ja auch einwandfrei erstellt - nur die Ausrichtung ist mein Problem ...
Gibt es den Befehl möglicherweise erst in späteren Corel-Versionen?

Gruß
fremoikaner

[fremoikaner]

kleiner Nachtrag, da es mir jetzt keine Ruhe gelassen hat ...
In Corel X7 gibt es den Befehl wenn man sr. eingibt; in X3 gibt es ihn offenbar noch nicht ...
Das Makro soll aber zumindest vorerst jedoch auf X3 laufen ...

Gruß
fremoikaner

[koter]

Hallo fremoikaner,

Du kannst die Position auch gleich beim Erstellen des Textes festlegen:

Code:

Sub TxtZAufAuswahl()
   Dim sr As ShapeRange
   Dim s1 As Shape
   Dim strName As String
   Dim X As Double, Y As Double
   
   If ActiveSelectionRange.Count = 0 Then Exit Sub 'Abbruch falls nichts ausgewählt ist
   
   Set sr = ActiveSelectionRange
   strName = "Mustertext"
   
   X = sr.RotationCenterX
   Y = sr.PositionY + 0.02
   
   Set s1 = ActiveLayer.CreateArtisticText(X, Y, strName, , , "1451_Eng_DB", 8, , , , cdrCenterAlignment)
End Sub

Du darfst natürlich den Rotationspunkt bei der Auswahl nicht verschieben.

Gruß

Koter

[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

[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

[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

[koter]

Hallo Fremoikaner,

...Wenn ich Dir ein Bier oder auch 2 ausgeben darf, lass' mich bitte wissen wie ...

...hab ich nicht verdient!

In meinem Code sind mindestens 2 Fehler.
Er dreht zur falschen Seite und vergrößert die gedrehte Schrift.

Der Teil zum drehen müsste so aussehen:

Code:

   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

Ein Fläschchen gönne ich mir trotzdem.
(natürlich aus eigenem Bestand)

Gruß

Koter

[fremoikaner]

Hallo Koter,

also ich finde, das Bierchen hast Du Dir mehr als verdient :-)

Ich verwende jetzt doch Dein Makro, da es a) schneller ist b) variabler (durch die Abstands-Variable) und c) mein Makro doch nicht 100% funzt; es hakelt noch wenn die Anzahl der Objekte in der sr >1 ist und diese nicht gruppiert sind.
Bevor ich da jetzt noch investiere, nehme ich doch einfach deines. Ich bin jetzt mal für ein paar Tage offline, danach ergänze ich noch meine kleinen Spezialitäten und werde hier nochmal den Code posten.

Vielen Dank nochmal und viele Grüße
fremoikaner