Ebenenweise kopieren

[koter]

Hallo Günther,

Das könnte mit einem Makro gehen:

Code:

Sub ImpDatei()
   Dim impOpt As StructImportOptions
   Dim impFlt As ImportFilter
   Dim Dateien As Documents
   Dim Datei1 As Document, Datei2 As Document, d As Document
   Dim EbenenD1 As Layers, EbenenD2 As Layers
   Dim L As Layer
   Dim Suffix1 As String, Suffix2 As String
   
   Set Datei1 = ActiveDocument
   
   For Each d In Documents
       If Not d = Datei1 Then Set Datei2 = d
   Next
   
   Set EbenenD1 = Datei1.Pages.First.Layers
   Set EbenenD2 = Datei2.Pages.First.Layers
   
   Suffix1 = Chr(32) & Datei1.Name: Suffix1 = Left(Suffix1, Len(Suffix1) - 4)
   Suffix2 = Chr(32) & Datei2.Name: Suffix2 = Left(Suffix2, Len(Suffix2) - 4)
   
   With Datei1
       .BeginCommandGroup "Ebenen umbenennen"
           For Each L In EbenenD1
               L.Name = L.Name & Suffix1
           Next
       .EndCommandGroup
       .Save
   End With
   
   Set impOpt = CreateStructImportOptions
   With impOpt
       .MaintainLayers = True
       .Mode = cdrImportFull
   End With
   
   With Datei2
       .BeginCommandGroup "Ebenen umbenennen"
           For Each L In EbenenD2
               L.Name = L.Name & Suffix2
           Next
       .EndCommandGroup
       .Pages.First.Layers.Top.Activate
       .BeginCommandGroup "Import"
        Set impFlt = .ActiveLayer.ImportEx(Datei1.FullFileName, cdrCDR, impOpt)
        impFlt.Finish
       .EndCommandGroup
   End With
   
   With Datei1
       .Undo
       .Save
   End With
   
   Datei2.Activate
   ActiveSelectionRange.Shapes.All.RemoveFromSelection
   Application.Refresh
End Sub

Das Makro verarbeitet nur die jeweils erste Seite.
Wenn das Makro bei Dir funktioniert und Du mehrseitige Dokumente verarbeiten willst,
melde Dich noch einmal.

Gruß

Koter