Ebenenweise kopieren

[Karthagos]

Hallo Koter,
ich habe jetzt noch etwas getestet. Beide Dateien geöffnet (alle Ebenen sichtbar und bearbeitbar)
   
Makro ausgeführt, Ergebnis
   
Anscheinend wurden nur die Ebenen der einen Datei mit dem Zusatz Afrika versehen

Daraufhin habe ich die Dateien neu geladen und auf nicht bearbeitbar gesetzt. Dann scheint das Makro zu funktionieren, wobei ich bei mehreren Versuchen den Fokus mal auf die eine oder die andere Datei (Tab) setzen musste, damit es funktioniert. Ganz habe ich es nicht verstanden, aber Hauptsache es führt zum Ziel.

[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

[Karthagos]

Hallo Koter,

habe irgendwie gestern Deine Antwort nicht mehr mitbekommen und jetzt durch Zufall im Forum gesehen, sorry.
Erstmal danke, jetzt klappt das Makro ohne Probleme auf Anhieb. Im Gegensatz zu vorher ist aber nichts mehr markiert. Vorher konnte ich die importierte Datei, in diesem Falle Afrika, die sich über der anderen, also Europa befand, über das Kreuz in der Mitte nach rechts oder links verschieben. Jetzt muss ich bei einer der beiden Dateien die Ebene vor Import auf gesperrt setzten, dann kann ich die andere durch alles Markieren verschieben oder mache ich wieder einen Gedankenfehler?

[koter]

Hallo Günther,

ich habe das Makro noch einmal umgebaut.
Das alte Makro hat bei jedem Import den Zusatz an die Ebennamen gehängt.
(Ein Bug der erst auffällt, wenn man eine zweite Datei importiert)

Das sind die Änderungen:

• Die Ebenen werden nur einmal umbenannt.
  
• Es muss nur eine Datei (Die Zieldatei) geöffnet sein.
  Wenn Nur eine Datei geöffnet ist, erscheint ein Import-Dialog.
  
• Wenn zwei Dateien geöffnet sind muss jetzt die Zieldatei ausgewählt sein.
  
• Die Objekte der importierten Ebenen sind nach dem Import ausgewählt
  und können sofort verschoben werden.
  

Code:

Sub EbenenImport2()
   Dim impOpt As StructImportOptions
   Dim impFlt As ImportFilter
   Dim Datei1 As Document, d As Document
   Dim L1 As Layer, L As Layer
   Dim EbenenD1 As Layers
   Dim ImpS As Shape
   Dim ImpDateiName As String, Suffix1 As String, Suffix2 As String, ImpSName As String
   Dim L1frei As Boolean
   Const EPropO As String = "Originalebene"
   
   Set Datei1 = ActiveDocument
   Set EbenenD1 = Datei1.Pages.First.Layers
   
   If Documents.Count < 1 Then Exit Sub
   If Documents.Count > 1 Then
       For Each d In Documents
           If Not d = Datei1 Then ImpDateiName = d.FullFileName: ImpSName = d.FileName
       Next
   Else
       ImpDateiName = CorelScriptTools.GetFileBox("CDR|*.cdr|Alle Dateien|*.*", "Importieren...", 0, "", , Datei1.FilePath)
   End If
   
   If Trim(ImpDateiName) = "" Then
       MsgBox "Keine Datei ausgewählt!", vbCritical, "Importfehler"
       Exit Sub
   Else
       ImpSName = Split(ImpDateiName, "\")(UBound(Split(ImpDateiName, "\")))
   End If
   
   Suffix1 = Chr(32) & Datei1.Name: Suffix1 = Left(Suffix1, Len(Suffix1) - 4)
   Suffix2 = Chr(32) & Split(ImpDateiName, "\")(UBound(Split(ImpDateiName, "\"))): Suffix2 = Left(Suffix2, Len(Suffix2) - 4)
       
   Application.Optimization = True
   Datei1.BeginCommandGroup "Importieren/Umbenennen"
   
   For Each L In EbenenD1
    If Not L.IsSpecialLayer Then
       If L1 Is Nothing Then Set L1 = L
       If Not L.Properties(EPropO, 1) Then
           L.Name = L.Name & Suffix1
           L.Properties(EPropO, 1) = True
           If L1 Is Nothing Then Set L1 = L
       End If
   End If
   Next
   
   L1frei = L1.Editable
   L1.Editable = True
   
   Set impOpt = CreateStructImportOptions
   With impOpt
       .MaintainLayers = True
       .Mode = cdrImportFull
   End With
   Set impFlt = Datei1.ActiveLayer.ImportEx(ImpDateiName, cdrCDR, impOpt)
   impFlt.Finish
   
   For Each L In EbenenD1
       If Not L.Properties(EPropO, 1) Then
           L.Name = L.Name & Suffix2
           L.Properties(EPropO, 1) = True
       End If
   Next
   
   Set ImpS = Datei1.Pages.First.FindShape(ImpSName)
   If Not ImpS Is Nothing Then
       Set L = EbenenD1.Parent.CreateLayer("Importebene")
       L.Properties(EPropO, 1) = True
       ImpS.MoveToLayer L
       If ImpS.TreeNode.ShapeType = cdrGroupShape Then ImpS.Ungroup
   End If
   
   L1.Editable = L1frei
   Datei1.EndCommandGroup
   Application.Optimization = False
   Application.Refresh
   
End Sub

Gruß

Koter

[Karthagos]

Hallo Koter,

zunächst wieder vielen Dank, alles perfekt. Es ist schon beeindruckend, wie Du die Makroprogrammierung, noch dazu aus der Ferne, realisierst. Ich denke, da gehört außer Erfahrung auch viel logisches Denken dazu. Noch dazu, weil ja bestimmte Ereignisse auch entsprechende Aktionen erfordern und berücksichtigt werden müssen.

Nochmals vielen Dank für Deine Mühe und Geduld und eine schöne Woche