CorelDraw für Schilder, Etiketten zu Lasern verwenden - Möglichkeiten....

[koter]

Hallo Drommer,

der Fehler lag bei dem Makro, Deine Vorlage ist OK.

Ich glaube mir sind Deine Anforderungen jetzt etwas klarer geworden.

Ich habe das Makro jetzt so umgebaut, dass es so wenig wie möglich auf die Vorlage zugreift.
Sortiert wird jetzt nur noch in der Druckdatei:

Code:

Dim xl As Object
Dim wb As Object
Dim Tabelle As Object
Dim Zellen As Object
Dim xlr As Object

Sub Start()

    Dim Dateiname As String
    
    Dateiname = Replace(Replace("Druckdatei-" & Date, ".", "-") & "-" & Time, ":", "-")
    
    If xltest Then
        Call Druckdatei(Dateiname)
    End If
    
    Set xl = Nothing
    Set wb = Nothing
    Set Tabelle = Nothing
    Set Zellen = Nothing
    Set xlr = Nothing
    
End Sub

Private Function xltest() As Boolean
    On Error GoTo Fehler
    xltest = False
    Set xl = GetObject(, "Excel.Application")
    Set wb = xl.activeWorkbook
    Set Tabelle = wb.activeSheet
    Set xlr = Tabelle.Range("A:A")
    xltest = True
    Exit Function
Fehler:
    If Err = 429 Then
         MsgBox "Fehler bem Datenaustausch mit Excel!", vbCritical, "Fehler"
    Exit Function
    End If
    MsgBox "Ein Fehler ist aufgetreten:" & vbCrLf & _
    Error(Err) & vbCrLf & vbCrLf & _
    "Das Makro wird beendet.", vbCritical, "Fehler"
End Function


Private Sub Druckdatei(ByVal DName As String)
    On Error GoTo Fehler
    Dim ND As Document, AD As Document
    Dim p As Page
    Dim NDRonden As ShapeRange
    Dim Rondentext As Shape, s As Shape
    Dim TextEbene As New Layer
    Dim RondenEbene As Layer, L As Layer
    Dim Zeiterfassung As Boolean
    
    Dim Z As Integer, DSZ As Integer, i As Integer
    Dim t1 As Single, t2 As Single
    Dim yZugabe As Double
    
    yZugabe = 0
    Zeiterfassung = True
    
    If Zeiterfassung Then t1 = Timer()
    Set Zellen = wb.activeSheet.Cells
    
    ActiveDocument.Unit = cdrMillimeter
    
    DSZ = xl.WorksheetFunction.CountA(xlr)
        
    Set AD = ActiveDocument
    Set ND = ActiveLayer.Shapes.All.CreateDocumentFrom
    
    For Each L In ActivePage.AllLayers
        If Not L.IsSpecialLayer Then
            L.Name = "Ronden"
            Set NDRonden = L.Shapes.All
            Exit For
        End If
    Next

    NDRonden.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
    ND.Name = DName
    ND.Unit = cdrMillimeter
    
    Set TextEbene = ND.ActivePage.CreateLayer("TextEbene")
    
    CorelScriptTools.BeginWaitCursor
    Application.Optimization = True

    Z = 1
    For i = 1 To DSZ
        Set Rondentext = TextEbene.CreateArtisticText(0, 0, Replace(Zellen(i, 1), "#", vbCrLf))
        With Rondentext
            .Text.Story.Size = 12
            .Text.Story.Alignment = cdrCenterAlignment
            .CenterX = NDRonden(Z).CenterX
            .CenterY = NDRonden(Z).CenterY - yZugabe
            .OrderToBack
        End With
        If Z < NDRonden.Shapes.Count Then
            Z = Z + 1
            NDRonden(Z).OrderToBack
        Else
            Z = 1
            Set p = ND.AddPages(1)
            p.Activate
            Set RondenEbene = p.Layers("Ronden")
            Set TextEbene = p.Layers("TextEbene")
            Set NDRonden = ND.Pages(1).Layers("Ronden").Shapes.All.CopyToLayer(p.Layers("Ronden"))
        End If
    Next i
    
    If Z < NDRonden.Count Then
        For i = Z To NDRonden.Count
            NDRonden(i).Delete
        Next i
    End If
    
    ActiveSelection.Shapes.All.RemoveFromSelection
    Application.Optimization = False
    ActiveWindow.Refresh
      
    If Zeiterfassung Then t2 = Timer
    CorelScriptTools.EndWaitCursor
    If Zeiterfassung Then MsgBox "fertig!" & vbCrLf & t2 - t1 & " Sekunden"
    ND.Dirty = False
    AD.Activate
    Exit Sub
    
Fehler:
    Application.Optimization = False
    MsgBox "Ein Fehler ist aufgetreten:" & vbCrLf & _
    Error(Err) & vbCrLf & vbCrLf & _
    "Prozedur: RondenBeschriftenXL" & vbCrLf & _
    "Das Makro wird beendet.", vbCritical, "Fehler"
        
End Sub

Die Ebene und die Objekte müssen nicht mehr umbenannt werden.
Es dürfen aber keine zusätzlichen Objekte auf der Ebene liegen.
Das Makro könnte diese nicht mehr von den zu beschriftenden Objekten unterscheiden,
es verarbeitet einfach alle Objekte der Ebene.

Ich hatte noch keine Zeit, das Makro ausgiebig zu testen, aber ich hoffe es funktioniert.

Gruß

Koter