VBA Objekte ausrichten
#11
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

Betriebssystem / Grafik-Software: Win7, Corel X3/X5/X7
Zitieren
#12
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

Betriebssystem / Grafik-Software: Win7, Corel X3/X5/X7
[-] 1 Benutzer bedankt sich bei fremoikaner für diesen Beitrag:
  • koter
Zitieren
#13
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
Zitieren



Möglicherweise verwandte Themen...
Thema Verfasser Antworten Ansichten Letzter Beitrag
  Ausrichten von Kurvenobjekten Boerni 2 65 Vor 8 Stunden
Letzter Beitrag: koter
  History (zuletzt geöffnete Objekte) Wild Thinng 1 107 23.05.2024, 17:25
Letzter Beitrag: miss_marple
  Mini-Objekte innerhalb einer Gruppe fassen und löschen migo 10 459 27.03.2024, 09:35
Letzter Beitrag: Boerni
  Objekte positionieren Sandfloh 2 261 23.03.2024, 18:12
Letzter Beitrag: Sandfloh
  Objekte und Punkte verbinden Herbert_M 2 220 05.02.2024, 20:17
Letzter Beitrag: norre
  Makro - Text an Rechteck ausrichten benni313 5 390 31.01.2024, 09:20
Letzter Beitrag: benni313
  2023 Objekte aus Dateimanager auf Arbeitsfläche ziehen ? miniprints 0 275 23.01.2024, 15:17
Letzter Beitrag: miniprints
  Häkchen bei "An Hilfslinie ausrichten" fixieren martens 15 1.003 16.10.2023, 18:55
Letzter Beitrag: martens
  Textzeilen in einzelne Text-Objekte aufteilen Karthagos 8 781 01.05.2023, 10:34
Letzter Beitrag: Karthagos
  Befehl: "Alle Objekte entsprerren" LuGa 1 552 12.03.2023, 15:07
Letzter Beitrag: LuGa