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

FAQFAQ  SzukajSzukaj  UżytkownicyUżytkownicy  GrupyGrupy
RejestracjaRejestracja  ZalogujZaloguj  DownloadDownload

Poprzedni temat «» Następny temat
Ten sam napis wszystkimi fontami
Autor Wiadomość
Trurl 
Ekspert



Pomógł: 66 razy
Wiek: 70
Dołączył: 04 Lut 2009
Posty: 952
Skąd: Warszawa
Wysłany: 2 Marzec 2021, 22:43   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 
Doradca
Grafik?


Wersja CorelDRAW: 2019
Pomógł: 14 razy
Dołączył: 29 Sty 2011
Posty: 114
Skąd: Czmoń
Wysłany: 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 
Ekspert



Pomógł: 66 razy
Wiek: 70
Dołączył: 04 Lut 2009
Posty: 952
Skąd: Warszawa
Wysłany: 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 
Doradca
Grafik?


Wersja CorelDRAW: 2019
Pomógł: 14 razy
Dołączył: 29 Sty 2011
Posty: 114
Skąd: Czmoń
Wysłany: 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

na
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
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Nowe zasady dotyczące cookies. Wykorzystujemy pliki cookies, aby nasz serwis lepiej spełniał Państwa oczekiwania. Można zablokować zapisywanie cookies, zmieniając ustawienia przeglądarki.
         
Strona wygenerowana w 0.08 sekundy. Zapytań do SQL: 14