VBA Objekte ausrichten - Druckversion

VBA Objekte ausrichten - Druckversion

+- Juergens-Workshops.de Forum (https://forum.juergens-workshops.de)
+-- Forum: Corel Grafik Forum (https://forum.juergens-workshops.de/forumdisplay.php?fid=65)
+--- Forum: Corel Draw (https://forum.juergens-workshops.de/forumdisplay.php?fid=93)
+--- Thema: VBA Objekte ausrichten (/showthread.php?tid=38682)

Seiten: 1 2

VBA Objekte ausrichten - fremoikaner - 19.05.2024

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

RE: VBA Objekte ausrichten - koter - 19.05.2024

Hallo fremoikaner,
willkommen im Forum!

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

s1.CenterX = sr.CenterX

Gruß

Koter

RE: VBA Objekte ausrichten - fremoikaner - 19.05.2024

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

RE: VBA Objekte ausrichten - fremoikaner - 19.05.2024

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

RE: VBA Objekte ausrichten - koter - 19.05.2024

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

RE: VBA Objekte ausrichten - fremoikaner - 20.05.2024

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

RE: VBA Objekte ausrichten - koter - 21.05.2024

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

RE: VBA Objekte ausrichten - fremoikaner - 21.05.2024

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

RE: VBA Objekte ausrichten - koter - 21.05.2024

Hallo Fremoikaner,

(21.05.2024, 16:37)fremoikaner schrieb: ...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

RE: VBA Objekte ausrichten - fremoikaner - 22.05.2024

Hallo Koter,

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

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