Pdf Exportieren mit CDR X5

[snow4fun]

Bei uns sind oft sehr große Mengen einseitiger Dateien von CDR nach PDF umzuwandeln, daher hab ich mir ein Makro zusammengestellt, welches alle CDR-Dateien eines zu wählenden Verzeichnisses als PDF-Dateien im gleichen Verzeichnis speichert.

Funktioniert unter X7, Dauer pro Datei ca. 1 - 5 Sekunden (kommt natürlich auch auf die Peripherie an).

Wem's hilft.
PS: Die Deklarationen fehlen noch wer also mag...

Code:

Sub CDR_in_PDF_speichern()
    ' getestet mit CorelDRAW X7, 22.02.2016

On Error Resume Next

    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Bitte das Verzeichnis auswählen" & Chr$(13) _
        & "Die PDF-Dateien werden im gleichen Verzeichnis abgelegt", 0, 17)
    Pfad = BrowseDir.items().Item().Path & "\"
    If Pfad = "" Then End

' MakroOptimierung
    ActiveDocument.BeginCommandGroup "CDR_in_PDF_speichern" ' Name der Aufgabe
        Optimization = True
        EventsEnabled = False                    ' deaktiviert Dokumentaktionen während Ausführung
        ActiveDocument.SaveSettings              ' speichert Änderungen der Form
        ActiveDocument.PreserveSelection = False ' optional, ausgewählte Formen nach Ausführung aufheben

    Dat1 = Dir(Pfad & "*.cdr", vbDirectory)
    While Dat1 <> ""
        Application.StatusBar = Dat1
        If Dat1 <> "." And Dat1 <> ".." And (GetAttr(Pfad & "\" & Dat1) And vbDirectory) <> 0 Then
            Folders.Add Pfad & "\" & Dat1
        Else
            OpenDocument (Pfad & Dat1)
            ActiveDocument.TextFormatter = 1700

            With ActiveDocument.PDFSettings
                .PublishRange = 1 ' CdrPDFVBA.pdfCurrentPage // 0 = CdrPDFVBA.pdfWholeDocument
                .PageRange = "1"
                .Author = "" ' für Namen oder Titel
                .Subject = ""
                .Keywords = ""
                .BitmapCompression = 2 ' CdrPDFVBA.pdfJPEG
                .JPEGQualityFactor = 10
                .TextAsCurves = False
                .EmbedFonts = True
                .EmbedBaseFonts = True
                .TrueTypeToType1 = True
                .SubsetFonts = True
                .SubsetPct = 80
                .CompressText = True
                .Encoding = 1 ' CdrPDFVBA.pdfBinary
                .DownsampleColor = True
                .DownsampleGray = True
                .DownsampleMono = True
                .ColorResolution = 200
                .MonoResolution = 600
                .GrayResolution = 200
                .Hyperlinks = True
                .Bookmarks = True
                .Thumbnails = False
                .Startup = 0 ' CdrPDFVBA.pdfPageOnly
                .ComplexFillsAsBitmaps = False
                .Overprints = True
                .Halftones = False
                .MaintainOPILinks = False
                .FountainSteps = 256
                .EPSAs = 0 ' CdrPDFVBA.pdfPostscript
                .pdfVersion = 6 ' CdrPDFVBA.pdfVersion15
                .IncludeBleed = False
                .Bleed = 31750
                .Linearize = False
                .CropMarks = False
                .RegistrationMarks = False
                .DensitometerScales = False
                .FileInformation = False
                .ColorMode = 3 ' CdrPDFVBA.pdfNative
                .UseColorProfile = True
                .ColorProfile = 1 ' CdrPDFVBA.pdfSeparationProfile
                .EmbedFilename = ""
                .EmbedFile = False
                .JP2QualityFactor = 10
                .TextExportMode = 0 ' CdrPDFVBA.pdfTextAsUnicode
                .PrintPermissions = 0 ' CdrPDFVBA.pdfPrintPermissionNone
                .EditPermissions = 0 ' CdrPDFVBA.pdfEditPermissionNone
                .ContentCopyingAllowed = False
                .OpenPassword = ""
                .PermissionPassword = ""
                .EncryptType = 1 ' CdrPDFVBA.pdfEncryptTypeStandard
                .OutputSpotColorsAs = 0 ' CdrPDFVBA.pdfSpotAsSpot
                .OverprintBlackLimit = 95
            End With
    
            Dat2 = Pfad & Left(Dat1, InStrRev(Dat1, ".")) & ".pdf"
            ActiveDocument.PublishToPDF Dat2
            ActiveDocument.Close

        End If
        Dat1 = Dir()
    Wend
    
' MakroOptimierung beenden
        ActiveDocument.PreserveSelection = True
        ActiveDocument.RestoreSettings
        EventsEnabled = True
        Optimization = False
    ActiveDocument.EndCommandGroup
    
    ' Grafikbereich neu aufbauen
    ActiveWindow.Refresh
    Application.Refresh
    Application.CorelScript.RedrawScreen

End Sub