Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen

[destiny]

Perfekt - das ist wirklich super, ich danke Dir.
Hab das nun für die Makro für die Grafiktextanpassung allgemein verwendet.
Klappt einwandfrei - 1000Dank

Code:
Sub GrafiktextVerkleinern()
Dim Seite As Page
Dim Grafiktext As ShapeRange
Dim Text As Shape
Dim Breite As Double
Breite = 80 '(%)
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrBottomCenter
ActiveDocument.BeginCommandGroup "Text verkleinern"
Optimization = True
For Each Seite In ActiveDocument.Pages
Set Grafiktext = Seite.Shapes.FindShapes(Query:="@type='text:artistic'")
If Not Grafiktext Is Nothing Then
For Each Text In Grafiktext
If Text.SizeWidth > Seite.SizeWidth / 100 * Breite Then
Text.Stretch 1 / Text.SizeWidth * (Seite.SizeWidth / 100 * Breite)
End If
Next
End If
Next
Optimization = False
ActiveDocument.EndCommandGroup
ActiveWindow.Refresh
End Sub

[koter]

Hallo Destiny,

Das Makro hast Du gut weiterentwickelt!
so läuft es ohne zu ruckeln und die Undo-Liste ist auch nicht so voll.

Allerdings schickt es bei mir die zu breiten Texte unter X7 einfach ins Nirvana:



Ich habe die Ursache nicht gefunden.

Noch ein Hinweis:

Im CQL-Statement hat sich ein Leerzeichen eingeschlichen,
das entfernt werden muss, damit das Makro läuft:

Query:="@type='text:artist_ic'"

Das ist aber nicht die Ursache für den verschwundenen Text.

Gruß

Koter

[destiny]

Super - ich danke Dir :-)

[destiny]

PS. Das habe ich auch bemerkt - wenn ich dann die Aktion rückgängig mache und noch einmal ausführe, klappt es komischerweise

[destiny]

Ich hoffe, ich nerve nicht ;-)
Gibt es auch eine Möglichkeit, den Text nicht allgemein zu verkleinern, sondern nur den Zeichenabstand entsprechend zu verringern?
Ist zwar unüblich, aber würde mich interessieren.

Ich wünsche Euch einen schönen Tag - hier gab es heute zum ersten Mal Schnee :kalt:

[koter]

Hallo Destiny,

Ich hoffe, ich nerve nicht ;-)

Nein, Jürgen hat das Forum ja eingerichtet, damit man sich über solche Fragen austauschen kann.
Wen das nervt, der soll es sich nicht anschauen.

...Gibt es auch eine Möglichkeit, den Text nicht allgemein zu verkleinern, sondern nur den Zeichenabstand entsprechend zu verringern?...

Die Möglichkeit gibt es, aber ob man es auch Praxis machen sollte?
Dabei kann nämlich so etwas herauskommen:



Und das, wo sich doch die Schriftkünstler so viel Mühe mit den Unterschneidungstabellen machen!

Das soll uns aber nicht hindern, damit herumzuspielen:

Code:

Sub KurztextVerschandeln()
    Dim Seite As Page
    Dim Kurztext As Shape
    Dim Breite As Double, BreiteA As Double
    Dim szp As Double
    Dim z As Double
    
    Breite = 80 '(%)
    
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.ReferencePoint = cdrCenter
    Statusleiste 0, , True, "Text verschandeln"
    ActiveDocument.BeginCommandGroup "Kurztext verschandeln"
    Optimization = True
    szp = 100 / ActiveDocument.Pages.Count
    For Each Seite In ActiveDocument.Pages
        BreiteA = Seite.SizeWidth / 100 * Breite
        Set Kurztext = Seite.Shapes("Kurztext")
        If Not Kurztext Is Nothing Then
            For i = 0 To -100 Step -1
                Kurztext.Text.Story.RangeKerning = i
                If Kurztext.SizeWidth <= BreiteA Then Exit For
            Next i
        End If
        z = z + 1
        Statusleiste szp * z
        If Application.Status.Aborted Then
            Exit For
        End If
    Next
    Optimization = False
    ActiveDocument.EndCommandGroup
    Statusleiste szp * z, True
    ActiveWindow.Refresh
End Sub

Sub Statusleiste(Fortschritt As Long, Optional Ende As Boolean = False, Optional Start As Boolean = False, Optional Text As String = "")
    If Start Then
         Application.Status.BeginProgress CanAbort:=True
         Application.Status.SetProgressMessage Text
         Application.Status.UpdateProgress Fortschritt
    End If
    If Text <> "" Then
         Application.Status.SetProgressMessage Text
    End If
    Application.Status.UpdateProgress Fortschritt
    If Ende Then
         Application.Status.EndProgress
    End If
End Sub

Die Ausführung dauert lange, weil das Makro die Zielbreite nicht berechnet sondern so lange probiert, bis es passt.
Du kannst die Schrittweite der For-Schleife erhöhen, dann geht es schneller, ist aber nicht mehr so genau.

Um das Makro abbrechen zu können habe ich die Sub „Statusleiste“ eingebaut.
Man kann dadurch das Makro mit der ESC-Taste abbrechen.
Bis zur Version X6 erschien in der Statusleiste ein Fortschrittsbalken, mit X7 klappt das leider nicht mehr.

Viel Spaß beim Programmieren und beim Schnee schaufeln.

Gruß

Koter

[destiny]

Wow...das ist eindeutig aufwendiger, als vorher.
Wahnsinn...ein ganzer Schwung Hieroglyphen ;-)
Vielen Dank für Deine Mühen

Ich werde es gleich mal testen...natürlich hast Du recht,
das sieht nicht mehr leserlich aus.

Meinst Du, es wäre besser, wenn sich nicht der Abstand dazwischen verringert,
sondern der Text nur in der Breite gestaucht wird?
Dann fällt es bei nicht ganz so langen Wörtern nicht so sehr auf, oder?

Hat es bei X7 gar nicht geklappt - oder war das nur auf den Fortschrittsbalken bezogen?

LG
Destiny

[koter]

Hallo Destiny,

Meinst Du, es wäre besser, wenn sich nicht der Abstand dazwischen verringert,
sondern der Text nur in der Breite gestaucht wird?

Ich finde, man sollte Schrift gar nicht stauchen, biegen verzerren oder sonstwie verunstalten.
Aber bei dem Thema bin ich auch ein alter, dogmatischer Sturkopf.

Hat es bei X7 gar nicht geklappt - oder war das nur auf den Fortschrittsbalken bezogen?

Doch, auch in X7 kann man das Makro durch den Einsatz von
Application.Status.BeginProgress CanAbort:=True
mit der ESC-Taste abbrechen.

Nur der Fortschrittsbalken wird nicht angezeigt, was ja die eigentliche Aufgabe dieser Funktion ist.
Da haben die Corel-Leute irgendetwas vermurkst. Sehr ärgerlich!

Gruß

Koter

[destiny]

Hallo Koter,

ich habe das jetzt bei X6 ausprobiert - hat problemlos funtkioniert.
Aber durch den Zeichenabstand wird das sehr schnell unbrauchbar.
Was müsste ich an diesem Code ändern, damit nicht die ganze Größe des Textes geändert wird, sondern nur die Breite entsprechend gestaucht?

Sub GrafiktextVerkleinern()
Dim Seite As Page
Dim Grafiktext As ShapeRange
Dim Text As Shape
Dim Breite As Double
Breite = 80 '(%)
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrBottomCenter
ActiveDocument.BeginCommandGroup "Text verkleinern"
Optimization = True
For Each Seite In ActiveDocument.Pages
Set Grafiktext = Seite.Shapes.FindShapes(Query:="@type='text:artistic'")
If Not Grafiktext Is Nothing Then
For Each Text In Grafiktext
If Text.SizeWidth > Seite.SizeWidth / 100 * Breite Then
Text.Stretch 1 / Text.SizeWidth * (Seite.SizeWidth / 100 * Breite)
End If
Next
End If
Next
Optimization = False
ActiveDocument.EndCommandGroup
ActiveWindow.Refresh
End Sub

Merci vorab :sei_gepriesen:

[koter]

Hallo Destiny,

wenn Du den for each-Block in Deinem Makro durch den folgenden ersetzt,
wird ein Zeilenumbruch Zwischen Vor- und Nachname gesetzt.
Erst wenn das immer noch zu breit ist wird gestaucht.

Code:

For Each Text In Grafiktext
    'geschütztes Leerzeichen (Strg+Umschlt+Leertaste) durch Zeilenumbruch ersetzen
    If Text.SizeWidth > Seite.SizeWidth / 100 * Breite Then
        Text.Text.Story = Replace(Text.Text.Story, Chr(160), vbCrLf)
        Text.CenterX = Seite.CenterX
        Text.CenterY = Seite.CenterY
    End If
    'Text stauchen
    If Text.SizeWidth > Seite.SizeWidth / 100 * Breite Then
        Text.SizeWidth = Seite.SizeWidth / 100 * Breite
        Text.CenterX = Seite.CenterX
        Text.CenterY = Seite.CenterY
    End If
Next

Damit das funktioniert musst Du das Leerzeichen im Seriendruck-Dokument
durch ein geschütztes Leerzeichen ersetzen (Strg+Umschlt+Leertaste).

Also das Leerzeichen zwischen den Seriendruckfeldern:
<Vorname>_<Nachname>

Willst Du nur stauchen, kannst Du den ersten if-Block entfernen.
Das Leerzeichen muss dann nicht ersetzt werden.

Gruß

Koter