Ebenen zusammenführen

[Karthagos]

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.)
   
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.

[koter]

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 Sub

Mit „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

[Karthagos]

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/9mtgl03m6...to98p&dl=0

[koter]

Hallo Günther,

ich habe leider nur X7, kann also die Dateien nicht öffnen.

Gruß

Koter

[Karthagos]

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/lsbw8jx2o...xqe00&dl=0

[koter]

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 Sub

Du 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.

...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

[Karthagos]

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.
     
Jetzt habe ich einen Bereich zum kopieren markiert
       
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?

[koter]

Hallo Günther,

...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:



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 Function

Die 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

[Karthagos]

Guten Morgen Koter, habe leider eine Fehlermeldung:
   

[koter]

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