Ebenenweise kopieren

[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