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