+- Juergens-Workshops.de Forum (https://forum.juergens-workshops.de)
+-- Forum: Corel Grafik Forum (https://forum.juergens-workshops.de/forumdisplay.php?fid=65)
+--- Forum: Corel Draw (https://forum.juergens-workshops.de/forumdisplay.php?fid=93)
+--- Thema: Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen (/showthread.php?tid=37103)
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 06.11.2016
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
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - koter - 07.11.2016
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:
![[Bild: seri-1yls03.jpg]](http://abload.de/img/seri-1yls03.jpg)
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
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 08.11.2016
Super - ich danke Dir :-)
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 08.11.2016
PS. Das habe ich auch bemerkt - wenn ich dann die Aktion rückgängig mache und noch einmal ausführe, klappt es komischerweise
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 08.11.2016
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:
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - koter - 08.11.2016
Hallo Destiny,
destiny schrieb: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.
destiny schrieb:...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:
![[Bild: seriendruck1oxxg2.jpg]](http://abload.de/img/seriendruck1oxxg2.jpg)
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 SubDie 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
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 08.11.2016
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
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - koter - 08.11.2016
Hallo Destiny,
destiny schrieb: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.
destiny schrieb: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
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - destiny - 09.11.2016
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?
Zitat: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:
Corel Draw X6/X7 Seriendruckausgabe - Text automatisch anpassen - koter - 09.11.2016
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
NextDamit 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