+- 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: Ebenen zusammenführen (/showthread.php?tid=38842)
Seiten:
1
2
Ebenen zusammenführen - Karthagos - 11.09.2025
Hallo,
wegen unseres bevorstehenden Umzugs versuchen wir, alles was wir nicht mehr brauchen, für kleines Geld zu verkaufen. Dafür habe ich, nach Vorgabe in dem Tegut-Markt in dem wir die Anzeigen aufhängen, jeweils 4 Anzeigen auf einer DIN-A4-Seite. (Um die Seitenränder auszunutzen, sind die zwei rechten Anzeigen auf den Kopf gestellt.)
[attachment=22308]
Des öfteren möchte ich Angebote, die in einer anderen Datei sind, in eine andere bestehende übertragen, weil dort ein Platz frei geworden ist. Jetzt kann ich das entsprechende Angebot markieren und an dem vorgesehenen Platz in der neuen Datei einfügen. Diese Einfügung wird jedoch als Gruppierung durchgeführt und nicht in die einzelnen Objektseiten.
Koter hatte mir vor längerem ein wunderbares Makro (Sub ImpDatei) geschrieben, dass die Ebenen bei gleichem Namen zusammenführt, allerdings für die komplette Datei. Ich hoffe, das geht auch mit einer partiellen markierten Auswahl.
RE: Ebenen zusammenführen - koter - 12.09.2025
Hallo Günther,
ganz verstanden habe ich Den Beitrag nicht. Objektseiten kenne ich z.B. nicht.
Du kannst ein Makro ausprobieren, dass eine Gruppe erzeugt, die sich wieder auf die Ursprungsebenen verteilen lässt:
Code:
Sub QuellgruppeErzeugen()
Dim s As Shape, gs As Shape
Dim GrZeit As String
If ActiveSelectionRange.Count < 2 Then
MsgBox "Bitte mindestens zwei Objekte auswählen!", vbExclamation, "Gruppe"
Exit Sub
End If
GrZeit = Now & "/" & Timer * 100
For Each s In ActiveSelectionRange.Shapes
s.Properties("QellGrEbene", 1) = GrZeit
s.Properties("QellGrEbene", 2) = s.Layer.name
Next
Set gs = ActiveSelectionRange.Shapes.All.Group
With gs
.Properties("QellGrEbene", 1) = GrZeit
.Properties("QellGrEbene", 2) = "Quellgruppe"
.name = "Quellgruppe"
.CreateSelection
End With
End Sub
Sub QuellgruppeVerteilen()
Dim s As Shape, sr As ShapeRange
Dim Zielebene As Layer
If ActiveSelectionRange.Count < 1 Then
MsgBox "Bitte eine Quellgruppe auswählen!", vbExclamation, "Gruppe auflösen"
Exit Sub
End If
If ActiveShape.Type = cdrGroupShape And ActiveShape.Properties("QellGrEbene", 2) = "Quellgruppe" Then
Set sr = ActiveShape.UngroupEx
Else
MsgBox "Bitte eine Quellgruppe auswählen!", vbExclamation, "Gruppe auflösen"
Exit Sub
End If
For Each s In sr
Set Zielebene = GREbene(s.Properties("QellGrEbene", 2))
s.MoveToLayer Zielebene
Next
End Sub
Function GREbene(n As String) As Layer
On Error GoTo Fehler
Set GREbene = ActivePage.Layers(n)
Exit Function
Fehler:
Set GREbene = ActivePage.CreateLayer(n)
End Function
Sub QGWiederherstellen()
Dim s As Shape, sr As Shape
Dim GrZeit As String
If ActiveSelectionRange.Count <> 1 Then
MsgBox "Bitte ein Quellgruppenobjekt auswählen!", vbExclamation, "Gruppe wiederherstellen"
Exit Sub
End If
GrZeit = ActiveShape.Properties("QellGrEbene", 1)
If GrZeit = "" Then
MsgBox "Bitte ein Quellgruppenobjekt auswählen!", vbExclamation, "Gruppe wiederherstellen"
Exit Sub
End If
For Each s In ActivePage.SelectableShapes
If s.Properties("QellGrEbene", 1) = GrZeit Then s.AddToSelection
Next
Set sr = ActiveSelectionRange.Group
With sr
.Properties("QellGrEbene", 1) = GrZeit
.Properties("QellGrEbene", 2) = "Quellgruppe"
.name = "Quellgruppe"
.CreateSelection
End With
End SubMit „QuellgruppeErzeugen“ kannst Du die Gruppe erstellen.
Die Gruppe kannst Du kopieren und in ein anderes Dokument einfügen.
Dort kannst Du sie mit „QuellgruppeVerteilen“ auflösen und auf die Ebenen verteilen.
Ich hoffe, dass die Makros bei Dir funktionieren.
Gruß
Koter
RE: Ebenen zusammenführen - Karthagos - 12.09.2025
Hallo Koter, wahrscheinlich habe ich wieder einmal schlecht formuliert.
Ich füge deshalb exemplarisch mal zwei cdr-Dateien ein, die beide die gleichen Obejktbegrifflichkeiten haben.
Die Test1.cdr stellt einen Thermobecher dar, die Test2.cdr eine Tischleuchte.
Jetzt möchte ich die Tischleuchte mit den entsprechenden Objektbeschreibungen in die Dateil Test 1.cdr, in diesem Fall in das untere linke Kästchen, einfügen.
Also muss ich nacheinander die einzelnen Objekte, Überschrift, Angebotstext, Fußnote… usw. in Test2 aktivieren, kopieren und dann in Test1 einfügen, das meinte ich mit Objektseiten. Das ist bei 5 Objekten, Überschrift, Angebotstext, Fußnote, Bild und Seitenlaschen einiges an Aufwand.
Ich hoffe, Du kannst die Vorgehensweise nachvollziehen. Das Ergebnis habe ich in Test 3.cdr dargestellt.
Nachdem ich wegen der Größenbeschränkung keine CorelDraw-Dateien einfügen kann, habe ich die gepackt in die Dropbox gelegt:
https://www.dropbox.com/scl/fi/9mtgl03m64rqpwspnvbhp/Tegut-Anzeigen.zip?rlkey=3xnzx938dl6dzojmpxeob0z6u&st=ioxto98p&dl=0
RE: Ebenen zusammenführen - koter - 12.09.2025
Hallo Günther,
ich habe leider nur X7, kann also die Dateien nicht öffnen.
Gruß
Koter
RE: Ebenen zusammenführen - Karthagos - 13.09.2025
Guten Morgen Koter,
habe die Dateien jetzt noch mal in Version 17 gespeichert, hoffe das ist richtig
Hier der neue Link:
https://www.dropbox.com/scl/fi/lsbw8jx2ornlpyxs2ji2c/Tegut-Anzeigen.zip?rlkey=1sclkh8sikcid00cshqvyut79&st=dtvxqe00&dl=0
RE: Ebenen zusammenführen - koter - 13.09.2025
Hallo Günther,
bei mir klappt es mit den Makros aus Beitrag 2.
Zum Markieren in einem Quadrant (einer Objektseite) habe ich noch ein Makro:
Code:
Private Function Quadrant(s As Shape) As Integer
Dim mX As Double, mY As Double, sX As Double, sY As Double
Dim q As Integer
mX = ActivePage.CenterX
mY = ActivePage.CenterY
sX = s.CenterX
sY = s.CenterY
Quadrant = Switch(sX < mX And sY > mY, 1, sX > mX And sY > mY, 2, sX < mX And sY < mY, 3, sX > mX And sY < mY, 4)
End Function
Sub markieren()
Dim s As Shape
Dim A As Variant
Dim i As Integer, q As Integer
If ActiveSelectionRange.Count = 0 Then Exit Sub
A = Array("Überschrift", "Angebotstext", "Fußnote mit Preis + Telefonnr", "Bild", "Seitenlaschen")
q = Quadrant(ActiveShape)
For i = 0 To UBound(A)
For Each s In ActivePage.Layers(A(i)).Shapes
If Quadrant(s) = q Then s.AddToSelection
Next
Next i
End Sub
Sub kopieren()
ActiveSelection.Copy
End Sub
Sub Stapel()
markieren
QuellgruppeErzeugen
kopieren
End SubDu musst ein Objekt im Quadrant auswählen und dann das Makro „markieren“ ausführen.
Es wird nur in Ebenen markiert, die im Array „A“ aufgeführt sind.
Du kannst aus der Markierung eine Quellgruppe erzeugen, diese kopieren und in ein anderes Dokument einfügen.
Dort kannst Du sie positionieren und dann auflösen (Makro: „QuellgruppeVerteilen“).
Dann sollten alle Objekte in den richtigen Ebenen sitzen.
Das Makro „Stapel“ ist nur ein Beispiel dafür, wie man einzelne Makros nacheinander ablaufen lassen kann.
Ich hoffe, dass die Makros bei Dir funktionieren.
(12.09.2025, 22:15)Karthagos schrieb: ...wahrscheinlich habe ich wieder einmal schlecht formuliert...
...oder ich war wieder einmal zu doof es zu verstehen.
Ich wünsche Dir einen möglichst stressfreien Umzug (falls das überhaupt geht).
Gruß
Koter
RE: Ebenen zusammenführen - Karthagos - 13.09.2025
Hallo Koter, erst mal wieder vielen Dank für Deine Mühe
Vielleicht könntest Du mir noch ein Makro schreiben, wie ich die Möbel aus einer 120 m² in eine 70 m² - Wohnung passen
Spaß beiseite; ich habe Deine Makros in Corel eingefügt.
[attachment=22309]
Jetzt habe ich einen Bereich zum kopieren markiert
[attachment=22310]
Es sind 22 Objekte in den entsprechenden entsperrten Ebenen markiert.
Wie kann ich jetzt die Makros am einfachsten ausführen, habe die Makro-Symbolleiste in den oberen Symbolleistenbereich eingefügt und auch das Scrip-Seitenfenster aktiviert. Bei so vielen Makros macht es ja vielleicht keinen Sinn, jedes einzeln in die Symbolleiste zu zsetzen?
RE: Ebenen zusammenführen - koter - 13.09.2025
Hallo Günther,
(13.09.2025, 20:29)Karthagos schrieb: ...Bei so vielen Makros macht es ja vielleicht keinen Sinn, jedes einzeln in die Symbolleiste zu zsetzen?
Das stimmt!
Ich habe noch zwei Makros zusammengeschustert, welche die anderen Makros ausführen:
![[Bild: Tegut.gif]](https://i.postimg.cc/6p1s9y1k/Tegut.gif)
Das sind die Makros „qKopieren“ und „qEinfügen“
Beim Ausführen von „qEinfügen“ wird der Mauspfeil zu einem Kreuz,
mit dem Du den Zielquadranten auswählen musst.
Code:
Sub qKopieren()
Dim HRe As Shape
Optimization = True
Set HRe = Hilfsrechteck(Quadrant(ActiveShape))
markieren
QuellgruppeErzeugen
kopieren
HRe.Delete
QuellgruppeVerteilen
Optimization = False
Application.Refresh
Refresh
End Sub
Sub qEinfügen()
Dim QGr As Shape, HRe As Shape
Dim q1 As Integer, q2 As Integer
q2 = quadrantKlick
Set QGr = ActiveLayer.Paste
Optimization = True
Select Case q2
Case 1
QGr.LeftX = 0
QGr.TopY = ActivePage.TopY
Case 2
QGr.RightX = ActivePage.RightX
QGr.TopY = ActivePage.TopY
Case 3
QGr.LeftX = 0
QGr.BottomY = 0
Case 4
QGr.RightX = ActivePage.RightX
QGr.BottomY = 0
End Select
Set HRe = QGr.Shapes("Hilfsrechteck")
q1 = HRe.Properties("Quadrant", 1)
If q1 = 1 Xor q1 = 3 Then
If q2 = 2 Or q2 = 4 Then QGr.Rotate 180
Else
If q2 = 1 Or q2 = 3 Then QGr.Rotate 180
End If
HRe.Delete
QuellgruppeVerteilen
Optimization = False
Application.Refresh
Refresh
End Sub
Private Function Hilfsrechteck(q As Integer) As Shape
Dim x As Double, y As Double, w As Double, h As Double
w = ActivePage.SizeWidth / 2
h = ActivePage.SizeHeight / 2
Select Case q
Case 1
x = 0: y = h
Case 2
x = w: y = h
Case 3
x = 0: y = 0
Case 4
x = w: y = 0
End Select
Set Hilfsrechteck = ActiveLayer.CreateRectangle2(x, y, w, h)
Hilfsrechteck.Properties("Quadrant", 1) = q
Hilfsrechteck.name = "Hilfsrechteck"
End Function
Private Function quadrantKlick() As Integer
Dim mX As Double, mY As Double, sX As Double, sY As Double
Dim q As Integer
Dim Shift As Long
Dim b As Boolean
mX = ActivePage.CenterX
mY = ActivePage.CenterY
b = False
b = ActiveDocument.GetUserClick(sX, sY, Shift, 10, False, cdrCursorWinCross)
q = Switch(sX < mX And sY > mY, 1, sX > mX And sY > mY, 2, sX < mX And sY < mY, 3, sX > mX And sY < mY, 4)
quadrantKlick = q
End FunctionDie Makros habe ich schnell zusammengeschustert.
Du solltest sie in der richtigen Reihenfolge ausführen, sonst kann es zu Abstürzen kommen.
ich hoffe es klappt!
Gruß
Koter
RE: Ebenen zusammenführen - Karthagos - 14.09.2025
Guten Morgen Koter, habe leider eine Fehlermeldung:
[attachment=22311]
RE: Ebenen zusammenführen - koter - 14.09.2025
Guten Morgen Günther,
Die Quadrant-Funktion (aus Beitrag 6) muss sich im selben Modul befinden.
Nachtrag:
(alle anderen Subs und Funktionen aus diesem Thema auch)
Gruß
Koter