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

[koter]

Hallo Drommer,

1. ...Ist es irgendwie machbar über Makros so etwas zu steuern? Vielleicht über die Breitengröße? Ist B > 300mm dann nur eine Seite ist B<300mm dann Matte daneben setzen... klar das Matte 3&4 dann auf Seite 2 landen würden...

ich gehe davon aus, dass Du mit „Breitengröße“ die Seitenbreite meinst. Ich habe das Makro danach geändert.
Teste mal, ob ich das richtig verstanden habe.

2. Zeilenabstand im Makro auf 220% (wurde bei Corel in % angegeben) einstellen. Diese Zahl irgendwo darstellen um Sie ggf. mal zu ändern.

Im Makro sind zwischen den Kommentarzeilen „Einstellungen“ und „Einstellungen_Ende“ einige Variablen, die Du ändern kannst. Falls Du Nachkommastellen brauchst, musst Du als Trennzeichen den Punkt nehmen, das Komma würde einen Fehler verursachen
(VBA ist ja in Englisch).

3. Sonderzeichen zu Corel hinzufügen? Könnte man Sonderzeichen in Corel hinzufügen – bin zurzeit auf der Suche nach einem Erdungs – Symbol.

Da hältst Du Dich am besten an das, was Hartmut und Norre geschrieben haben, die beiden wissen da besser Bescheid als ich.

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, NDRonden1 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, KeinAbstand As Boolean
    
    Dim Z As Integer, DSZ As Integer, i As Integer
    Dim t1 As Single, t2 As Single
    Dim yZugabe As Double, LX As Double, Mattenbreite As Double
    Dim Zeilenabstand As Single, Schriftgröße As Single
    
    Zeiterfassung = True
    
    If Zeiterfassung Then t1 = Timer()
    Set Zellen = wb.activeSheet.Cells
    
    ActiveDocument.Unit = cdrMillimeter
    
    'Einstellungen_________________________
    
    yZugabe = 0
    KeinAbstand = False
    
    Mattenbreite = 260
    Schriftgröße = 18.5
    Zeilenabstand = 220
    KeinAbstand = False

    'Einstellungen_Ende____________________
    
    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
    LX = NDRonden.LeftX
    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
            With .Text.Story
                 .Size = Schriftgröße
                 .SetLineSpacing cdrPercentOfCharacterHeightLineSpacing, Zeilenabstand
                 .Alignment = cdrCenterAlignment
            End With
            .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
            If ND.ActivePage.SizeWidth / Mattenbreite >= 2 And _
                NDRonden.SizeWidth <= Mattenbreite And _
                ND.ActivePage.RightX - NDRonden.RightX >= Mattenbreite _
            Then
                Set NDRonden = NDRonden.CopyToLayer(ActivePage.Layers("Ronden"))
                NDRonden.OrderToBack
                If KeinAbstand Then
                    NDRonden.LeftX = NDRonden.SizeWidth
                Else
                    NDRonden.LeftX = Mattenbreite
                End If
                
            Else
                Set p = ND.AddPages(1)
                p.Activate
                Set RondenEbene = p.Layers("Ronden")
                Set TextEbene = p.Layers("TextEbene")
                Set NDRonden = NDRonden.CopyToLayer(p.Layers("Ronden"))
                NDRonden.LeftX = LX
            End If
        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

Gruß

Koter