Ebenenweise kopieren

[koter]

Hallo Günther,

wenn unsere unterschiedlichen Versionen das Makro nicht anders interpretieren, sollte es egal sein ob Ebenen gesperrt sind oder nicht.

Es gibt eine Ausnahme: Die erste Ebene in der Zieldatei muss bearbeitbar sein.
Ich habe das Makro so geändert, dass es diese Ebene bearbeitbar schaltet.

Bevor Du das Makro startest, muss die Quelldatei ausgewählt sein (den Focus haben):



Das Makro schaltet die Bildaktualisierung ab. Dadurch sollte es etwas schneller laufen.

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, L2 As Layer, tempEbene As Layer
   Dim Suffix1 As String, Suffix2 As String
   Dim L2frei As Boolean: L2frei = True
   Dim L1S As Shape
   Dim L1Anz As Integer: L1Anz = 0
   Dim L2Anz As Integer: L2Anz = 0
   
   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
   
   For Each L In EbenenD1
       If Not L.IsSpecialLayer Then
           L1Anz = L2Anz + 1
       End If
   Next
   
   For Each L In EbenenD2
       If Not L.IsSpecialLayer Then
           If L2 Is Nothing Then Set L2 = L
           If Not L2.Editable Then
               L2frei = L2.Editable
               L2.Editable = True
           End If
           L2Anz = L2Anz + 1
       End If
   Next
   
   Application.Optimization = True
   
   Suffix1 = Chr(32) & Datei1.Name: Suffix1 = Left(Suffix1, Len(Suffix1) - 4)
   Suffix2 = Chr(32) & Datei2.Name: Suffix2 = Left(Suffix2, Len(Suffix2) - 4)
   
   If L1Anz = 1 Then
        Set tempEbene = EbenenD1.Parent.CreateLayer("tempEbene")
        tempEbene.CreateArtisticText 0, 0, "Temporäre Ebene: Bitte löschen"
    End If

   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 = L2.ImportEx(Datei1.FullFileName, cdrCDR, impOpt)
        impFlt.Finish
       .EndCommandGroup
   End With
   
   With Datei1
       .Undo
       .Save
   End With
   
   L2.Editable = L2frei
   
   If Not tempEbene Is Nothing Then
      EbenenD2(tempEbene.Name & Suffix1).Delete
      tempEbene.Delete
      Datei1.Save
   End If
   
   Datei2.Activate
   ActiveSelectionRange.Shapes.All.RemoveFromSelection
   Application.Optimization = False
   
   Application.Refresh
   
End Sub

Manchmal verursacht das Abschalten der Bildaktualisierung einen Absturz.
Sollte das bei Dir vorkommen musst Du diese Zeile herausnehmen:

Code:

Application.Optimization = True

Gruß

Koter