.NET: How can I control the "Only Objects on page exporting" by PDF-Export?

I want to write a small AddIn to automate our PDF Creation. I can set all the properties of the PDF. But I need control the "Only Objects on page "-Option on the PDF-Export Dialog. How can I do it?

            With corelApp.ActiveDocument.PDFSettings
                .PublishRange = 2 ' CdrPDFVBA.pdfSelection
                .PageRange = "1"
                .Author = PDF_Author
                .Subject = corelApp.ActiveDocument.FullFileName
                .Keywords = corelApp.ActiveDocument.FullFileName

...

           End With

           corelApp.ActiveDocument.PublishToPDF(PDF_FileName)

  • I beleive you are asking how to export the current page, you can do that by using:

    .PublishRange = 1
    

    or

    .PublishRange = pdfExportRange.pdfCurrentPage
    

    Hope that helps, 

    -Shelby

  • Hi,

    I found this difficult when building my own PDF automation script, as often have large objects off the page (that I don't want to include) AND multiple pages, which means not being able to use pdfCurrentPage or pdfSelection.

    Therefore, I use:

    'Delete all Objects not on the page
    Dim sr As ShapeRange, Deleted As Long
    Dim i As Integer
    ActiveDocument.SelectableShapes.All.AddToSelection 'Adds all shapes to selection
    For i = 1 To ActivePage.Layers.count
    ActivePage.Layers(i).Shapes.All.RemoveFromSelection 'Loops through the layers on the current page and remove shapes from selection
    Next i
    Set sr = ActiveSelectionRange
    Deleted = sr.count 'assign count so we can check whether we need to undo the delete later
    If Deleted > 0 Then
        sr.Delete
    End If

    I take a count to determine whether I need to delete any objects and also use this later in the code to determine whether to run an undo to bring the deleted objects back.

  • My full code is:

    Sub AutoPDF()
    
    On Error GoTo Error_Handler
        
        'Defines the current folder of the file you are working on. If no folder, it defaults to Temporary Files
        Dim intR As Integer
        Dim sPages As String
        
        intR = MsgBox("Do you want to use the last used location?", vbYesNoCancel)
        
        If intR = vbNo Then
            sFolderPath = "O:\Temporary Files\"
        ElseIf intR = vbCancel Then
            Exit Sub
        End If
        
        
        'Check pages required
        If ActiveDocument.Pages.count > 1 Then
        
            intR = MsgBox("Do you want to PDF only the current page?", vbYesNoCancel)
            
            If intR = vbNo Then
            
                Dim strDefault As String
                strDefault = "1-" & ActiveDocument.Pages.count
                
                sPages = InputBox("Which pages would you like to output?" & vbCrLf & "Enter the page range. e.g. 1-8 or 1,3,4,7", "Pages Required?", strDefault)
                
            ElseIf intR = vbYes Then
                sPages = 1
            ElseIf intR = vbCancel Then
                Exit Sub
            End If
            
        Else
            sPages = 1
        End If
        
        
        'Defines the default save name (current file name) for the PDF
        Dim fileTitle As String
        fileTitle = Replace(ActiveDocument.FileName, ".cdr", "")
            
            
        Dim myFile As String 'The name of our file
        myFile = CorelScriptTools.GetFileBox("All Files (*.*)|*.*", "Save As Secure PDF", 1, "" & fileTitle, "pdf", "" & sFolderPath, "Save")
        
        
        'A quick check to make sure a file name was entered
        If myFile = "" Then
            MsgBox "No filename given, Please try again."
            Exit Sub
        End If
        
        
        'Checks if the file exists and asks to replace, if so it prints
        If Dir(myFile) <> "" Then
            replaceFile = MsgBox(myFile & " already exists. Replace?", vbYesNo)
            If replaceFile = vbNo Then
                MsgBox "Saving cancelled"
                Exit Sub
            End If
        End If
        
        'Get current page
        Dim intPageNo As Integer
        intPageNo = ActiveDocument.ActivePage.Index
        
        'Delete all Objects not on the page
        Dim sr As ShapeRange, Deleted As Long
        Dim i As Integer
        ActiveDocument.SelectableShapes.All.AddToSelection 'Adds all shapes to selection
        For i = 1 To ActivePage.Layers.count
            ActivePage.Layers(i).Shapes.All.RemoveFromSelection 'Loops through the layers on the current page and remove shapes from selection
        Next i
        Set sr = ActiveSelectionRange
        Deleted = sr.count 'assign count so we can check whether we need to undo the delete later
        If Deleted > 0 Then
            sr.Delete
        End If
        
        
        'Convert All Text to Curves
        Dim count As Integer
        count = ConvertAllTextToCurves
        
        
        'Return to original current page
        ActiveDocument.Pages(intPageNo).Activate
        
        
        'Set the PDF Settings to use
        With ActiveDocument.PDFSettings
            
            If InStr(1, sPages, "-") Or InStr(1, sPages, ",") Then
                .PublishRange = 3 ' CdrPDFVBA.pdfPageRange
                .PageRange = sPages
            Else
                .PublishRange = sPages ' CdrPDFVBA.pdfWholeDocument
            End If
            
            .Author = "Company Name"
            .Subject = ""
            .Keywords = "© Copyright " & Year(Date) & " Company Name"
            .BitmapCompression = 2 ' CdrPDFVBA.pdfJPEG
            .JPEGQualityFactor = 25
            .TextAsCurves = True
            .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
            .SpotColors = True
            .MaintainOPILinks = False
            .FountainSteps = 256
            .EPSAs = 0 ' CdrPDFVBA.pdfPostscript
            .pdfVersion = 6 ' CdrPDFVBA.pdfVersion15
            .IncludeBleed = False
            .Bleed = 0
            .Linearize = False
            .CropMarks = False
            .RegistrationMarks = False
            .DensitometerScales = False
            .FileInformation = False
            .ColorMode = 3 ' CdrPDFVBA.pdfNative
            '.UseColorProfile = False
            '.ColorProfile = 1 ' CdrPDFVBA.pdfSeparationProfile
            .EmbedFilename = ""
            .EmbedFile = False
            .JP2QualityFactor = 25
            .TextExportMode = 1 ' CdrPDFVBA.pdfTextAsAscii
            .PrintPermissions = 1 ' CdrPDFVBA.pdfPrintPermissionLowResolution
            .EditPermissions = 0 ' CdrPDFVBA.pdfEditPermissionNone
            .ContentCopyingAllowed = False
            .OpenPassword = ""
            .PermissionPassword = "#######"
            .OutputSpotColorsAs = 0 ' pdfSpotAsSpot
            .EncryptType = 1 ' CdrPDFVBA.pdfEncryptTypeStandard
        End With
        
        'Create the PDF
        ActiveDocument.PublishToPDF myFile
        
        MsgBox ("File Saved As " & myFile)
        
        'Undo modules were here before being moved to ExitHere
        
        'Return to original current page
        ActiveDocument.Pages(intPageNo).Activate
        
        'Save the last used folder
        sFolderPath = Left(myFile, InStrRev(myFile, "\"))
        
        'Now open it in Acrobat
        MyPath = "C:\Program Files (x86)\Adobe\Acrobat 10.0\Acrobat\Acrobat.exe"
        Shell MyPath & " " & myFile, vbNormalFocus
    
    ExitHere:
    
        'Revert all text back to text (undo the ConvertAllTextToCurves method)
        If count > 0 Then
            ActiveDocument.Undo
        End If
        
        'Bring back anything deleted off the desktop
        If Deleted > 0 Then
            ActiveDocument.Undo
        End If
        
        Exit Sub
    
    Error_Handler:
    
        Select Case Err.Number
        
        Case -2147467259
        
            MsgBox "CorelDRAW cannot create the PDF as" & vbNewLine & "this is currently in use, or open.", vbOKOnly, "Access Denied"
            
            Resume ExitHere
        
        Case Else
        
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbOKOnly, "Error"
            
            Resume ExitHere
        
        End Select
    
    End Sub
    

    And the ConvertAllTextToCurves function (which converts all text to curves - even inside groups and powerclips) is:

    Public Function ConvertAllTextToCurves() As Integer
    
        Dim sr As Shapes
        Dim sr2 As ShapeRange: Set sr2 = New ShapeRange
        Dim SrGroup As ShapeRange
        Dim s1 As Shape
        Dim s2 As Shape
        Dim s3 As Shape
        Dim sp As Shape
        Dim pwc1 As PowerClip
        Dim pwc2 As PowerClip
        
        Dim p As Page
        Dim i As Integer
        
        For Each p In ActiveDocument.Pages
        
            p.Activate
            Set sr = ActivePage.Shapes
            
            For Each s1 In sr
                
                Set pwc1 = Nothing
                
                'add if text type
                If s1.Type = cdrTextShape Then
                    sr2.Add s1
                End If
                
                'check through groups
                If s1.Type = cdrGroupShape Then
                
                    Set SrGroup = s1.Shapes.All
                    
                    For Each s2 In SrGroup
                    
                        Set pwc2 = Nothing
                        
                        'add if text type
                        If s2.Type = cdrTextShape Then
                            sr2.Add s2
                        End If
                        
                        ' check through powerclips inside the group
                        Set pwc2 = s2.PowerClip
                
                        If Not pwc2 Is Nothing Then
                          For Each sp In pwc2.Shapes
                            If sp.Type = cdrTextShape Then
                                sr2.Add sp
                            End If
                            
                            If sp.Type = cdrGroupShape Then
                                Set SrGroup = sp.Shapes.All
                                For Each s3 In SrGroup
                                    sr2.Add s3
                                Next s3
                            End If
                          Next sp
                        End If
                        
                        'sr2.Add s2
                    Next s2
        
                End If
                
                ' check through powerclips
                Set pwc1 = s1.PowerClip
                
                If Not pwc1 Is Nothing Then
                
                    For Each sp In pwc1.Shapes
                    
                        Set pwc2 = Nothing
                    
                        If sp.Type = cdrTextShape Then
                            sr2.Add sp
                        End If
                        
                        If sp.Type = cdrGroupShape Then
                            Set SrGroup = sp.Shapes.All
                            For Each s2 In SrGroup
                                sr2.Add s2
                            Next s2
                        End If
                        
                        
                        ' check through powerclips inside the powerclip
                        Set pwc2 = sp.PowerClip
                
                        If Not pwc2 Is Nothing Then
                          For Each s2 In pwc2.Shapes
                            If s2.Type = cdrTextShape Then
                                sr2.Add s2
                            End If
                            
                            If s2.Type = cdrGroupShape Then
                                Set SrGroup = s2.Shapes.All
                                For Each s3 In SrGroup
                                    sr2.Add s3
                                Next s3
                            End If
                          Next s2
                        End If
                        
                      
                    Next sp
                End If
                
            Next s1
        
        Next p
        
        sr2.ConvertToCurves
        
        ConvertAllTextToCurves = sr2.count
    
    End Function