Zobacz temat - Ten sam napis wszystkimi fontami

Corel FORUM
Forum użytkowników programów firmy Corel. Grafika wektorowa, rastrowa i obróbka zdjęć cyfrowych

Makra - Ten sam napis wszystkimi fontami

Trurl - 2 Marzec 2021, 22:43
Temat postu: Ten sam napis wszystkimi fontami

Potrzebuję makra, które ten sam jednowyrazowy napis, powiedzmy "Technologia" układałoby na stronie A4 w trzech kolumnach i jakichś 16 wierszach, zmieniając za każdym razem krój czcionki, zachowując tylko stopień pisma, powiedzmy 16 punktów, Chciałbym to zrobić wszystkimi fontami zainstalowanymi w systemie (ze 200 krojów). Chciałbym też, żeby pod każdym napisem pojawiała się nazwa użytego fontu, powiedzmy Arialem 8-punktowym.
Taki plik miałby kilkanaście stron, bo mam dużo fontów.
Choć używam Corela od jakichś 25 lat, iestety, nie potrafię pisać w nim makr, bo nie wiem, jak można się nauczyć języka programowania. To pewnie jakaś odmiana VB, ale nie ma do tego podręcznika. Proszę więc, żeby ktoś z Was napisał takie makro.

;-)

Martin Nez - 5 Marzec 2021, 19:01

Spróbuj użyć tego kodu:

Kod:

Dim a() As String

Sub trurl()
Dim b As String
Dim c As Shape
Dim d, e, f, g, h As Integer
Dim i, j As Double

ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrTopLeft
b = InputBox("Podaj napis:")
i = 10: j = ActivePage.SizeHeight - 10: h = 1
Optimization = True: bb
For d = 1 To UBound(a)
If Left(a(d), 1) = "@" Then h = h + 1
Next
For e = 1 To UBound(a) / 16 / 3
For f = 1 To 16
For g = 1 To 3
Set c = ActiveLayer.CreateArtisticText(i, j, b, , , a(h), 16)
Set c = ActiveLayer.CreateArtisticText(i, j - 5, a(h), , , "Arial", 8)
i = i + 60: h = h + 1
If h = Application.FontList.Count Then Exit Sub
Next
i = 10: j = j - 18
Next
ActiveDocument.AddPages 1: i = 10: j = ActivePage.SizeHeight - 10
Next
Optimization = False: Refresh
End Sub

Sub bb()
Dim b, c, d As Integer
Dim e As String
d = Application.FontList.Count
ReDim a(d)
For b = 1 To d
a(b) = Application.FontList.Item(b)
Next
For b = 1 To d - 1
For c = 0 To d - 1
If a(c) > a(c + 1) Then
e = a(c): a(c) = a(c + 1): a(c + 1) = e
End If
Next
Next
End Sub

Pozdr,
MN

Trurl - 6 Marzec 2021, 12:48

Dziękuję, ale coś chyba jest nie tak (niewykluczone, że ja :-)

). Uruchamiam to makro z Makromenedżera, wpisuję słowo, które ma to makro obrabiać i widać, że coś liczy, ale, niestety, nie pojawia się żaden rezultat jego działalności.. Może to kwestia wersji Corela, którą mam? Mam Corela X5. A może źle je uruchamiam? Podpowiedz coś, proszę.

Martin Nez - 7 Marzec 2021, 21:47

Witam,
zakładam, że masz otwarty pusty dokument. Czy makro kończy działanie? U siebie mam ponad 800 fontów i trzeba odczekać 1-2 minuty zanim skończy tworzyć dokument. Spróbuj użyć poniższego kodu, żeby sprawdzić ile faktycznie fontów jest u Ciebie. Dla makra regular, bold, italic itp to oddzielne fonty.

Kod:

Sub ileFontow()
msbox(application.fontlist.count)
End Sub

Możesz też spróbować zamienić linię:

Kod:

If h = Application.FontList.Count Then Exit Sub

Kod:

If h = 100 Then Exit Sub

Wtedy skrypt nie wygeneruje całego dokumentu, ale po 100 fontach zakończy działanie. Jeśli wszystko będzie ok to uruchom poprzedni kod i bądź cierpliwy. ;-)
Pozdr,
MN