Corel FORUM

[Printgrav]

Witam, proszę o pomoc przy stworzeniu makro, używam kodu poniżej, chodzi żeby dodać linijkę do kodu żeby nie nadpisywał projektu tylko tworzył nowy . Naciskam dany przycisk i zapisuje mi nowy projekt z corela 2020 do x4 z dowolnie wpisana nazwą. Przy nowym projekcie kod nie działa a przy otwartym nadpisuje. Proszę o pomoc
kod:
Sub ZapiszDoX4()
Dim Nazwa As String
Dim Katalog As String
Nazwa = ActiveDocument.FileName
Katalog = ActiveDocument.FilePath

Dim Zapisz As StructSaveAsOptions
Set Zapisz = CreateStructSaveAsOptions
With Zapisz
.Filter = cdrCDR
.Version = cdrVersion15
.EmbedVBAProject = True
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = True
End With

ActiveDocument.SaveAs Katalog + "" + Nazwa, Zapisz
End Sub

[Martin Nez]

Witam,
ja zrobiłbym to tak:

Kod:

Sub Printgrav()     Dim Nazwa As String     Dim Katalog As String     If ActiveDocument.FileName <> "" Then         Nazwa = InputBox("Podaj nazwe pliku:", "Nazwa", ActiveDocument.FileName)         Katalog = ActiveDocument.FilePath     Else         Nazwa = InputBox("Podaj nazwe pliku:", "Nazwa", "Bez tytulu.cdr")         Katalog = Environ("homedrive") & Environ("homepath") & "\Desktop\"     End If         Dim Zapisz As StructSaveAsOptions     Set Zapisz = CreateStructSaveAsOptions     With Zapisz         .Filter = cdrCDR         .Version = cdrVersion15         .EmbedVBAProject = True         .IncludeCMXData = False         .Range = cdrAllPages         .EmbedICCProfile = True     End With         ActiveDocument.SaveAs Katalog + "" + Nazwa, Zapisz End Sub

Pozdr,
MN

[Printgrav]

Dzięki za kodzik, bardzo pomocny. Zastanawiam się tylko czemu zmienia się drastycznie rozmiar np: projekt ma 257kb, po zapisie normalnie do wersji 15 rozmiar prawie bez zmian, po zapisie przez kod rozmiar zmienia się na 1,57MB. Co powoduje taką zmianę?
W kodzie brakuje mi takiej opcji jak:
-zapis do wskazanego miejsca, nie z automatu na pulpit
-automatyczny zapis cdr ( teraz jak zmaże koncówkę przy wpisywaniu nazwy plik sie nie zapisze)
Jest możliwa taka opcja?

[Printgrav]

Z wielkością pliku juz sobie poradziłem, zmieniłem: .EmbedICCProfile = false

[Martin Nez]

To może spróbuj innego podejścia:

Kod:

Sub Printgrav()     Dim Nazwa As String     Dim Zapisz As StructSaveAsOptions     Set Zapisz = CreateStructSaveAsOptions     With Zapisz         .Filter = cdrCDR         .Version = cdrVersion15         .EmbedVBAProject = True         .IncludeCMXData = False         .Range = cdrAllPages         .EmbedICCProfile = False     End With         Nazwa = CorelScriptTools.GetFileBox("Pliki CorelDRAW (*.cdr)|*.cdr", "Zapisz jako...", 1, ActiveDocument.FileName, , ActiveDocument.FilePath)     If Nazwa <> "" Then ActiveDocument.SaveAs Nazwa, Zapisz End Sub

Pozdr,
MN

[Printgrav]

Dziękuje bardzo właśnie o to mi chodziło, bardzo ułatwi mi to pracę, bardzo mi pomogłeś.
Jest jeszcze możliwe makro do exportu do BMP ale o określonych parametrach, chodzi mi o podpięcie pod przycisk:
Eksport-BMP-rozmiar szer.100%, wysokość 100%-rozdzielczość 500dpi- tryb kolorów skala szarości (8-bit)- opcje wygładzenie

Pozdrawiam i jeszcze raz dzieki

[Martin Nez]

Tak na szybko...

Kod:

Sub Printgrav2()     Dim Nazwa As String     Nazwa = CorelScriptTools.GetFileBox("Bitmapa (*.bmp)|*.bmp", "Eksportuj jako...", 1, ActiveDocument.FileName, , ActiveDocument.FilePath)     If Right(Nazwa, 3) = "cdr" Then Nazwa = Left(Nazwa, Len(Nazwa) - 3) & "bmp"     Dim Rozdzielczosc As Long     Rozdzielczosc = 500     Dim ExpFltr As ExportFilter     Set ExpFltr = ActiveDocument.ExportBitmap(Nazwa, cdrBMP, cdrAllPages, cdrGrayscaleImage, , , Rozdzielczosc, Rozdzielczosc, cdrNormalAntiAliasing, False, False, False)     ExpFltr.Finish End Sub

Pozdr,
MN

[Printgrav]

Dziękuję o to chodziło. Jest jednak różnica przy normalnym eksporcie a tym z kodu. Po kodzie rozjaśnia trochę zdjęcie, nie mam pojęcia jaki parametr odpowiada za taką zmianę.
Doszedłem że w tej chwili zapisuje jako: Paleta (8-bitowa) a potrzeba jako Skala szarości (8-bitowa)
Po kilku testach ten sam efekt daje: Paleta (8-bit)- skala szarości (wtedy się zmienia na jaśniejsze, efekt jak po kodzie)
Paleta ( 8-bit)- Paleta Adaptacyjna ( daje dobry efekt ten sam co Skala Szarości 8-bit, czyli nie zmienia oryginalnego zdjęcia)

[Printgrav]

Do szczęścia potrzebne mi ostatnie makro:
Zapis do: PLT ( Plik plotera HGPL ) - Strona: rozmiar ISO A4, Pisak: Black- Zaawansowane: wypełnienie brak, usuń ukryte linie, Rozdzielczość krzywej: 0,0 milimetry

Mam taki kod ale potrzeba modyfikacji i zapis żeby był tak jak poprzednio pan robił do wskazanego miejsca )

Sub ExportToWinLase()
' Saves file as .plt
Dim savetopath As String
Dim expopt As StructExportOptions
'Dim yn As String

Set expopt = CreateStructExportOptions
expopt.UseColorProfile = False

Dim expflt As ExportFilter

Set expflt = ActiveDocument.ExportEx("c:\test.plt", cdrHPGL, cdrAllPages, expopt)
expflt.ShowDialog
expflt.Finish

End Sub

Dziękuję