Pdf Exportieren mit CDR X5

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