Ebenen zusammenführen

[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