Hi.
I am wanting to modify an existing VBA script to add an addition export file for a selected graphic. I am currently exporting to pdf, emf and svg with the script shown below. I am wanting to export also to png. Please advise where the code below needs correcting. The actual part of the code I am having issues with is:Set exportOptions = doc.ExportOptions.pngWith exportOptions.TransparentBackground = True.Resolution = 300 ' Set desired resolutionEnd With.Export ExportPath & "Test.png", cdrPNG, exportOptionsLog.WriteLine Count & vbTab & ExportPath & "Test.png"Msgbox "PNG export file created", vbOKOnly
The full script is shown below:
Const FileSystemObject = "Scripting.FileSystemObject"Const CorelDraw = "CorelDraw.Application"Const ExportPath = "\\rozelle-fp\geodata\SURVEY-SPATIAL\Spatial\ArcGIS\Stylesheets\SVGfiles\"Const SourcePath = "\\rozelle-fp\geodata\SURVEY-SPATIAL\Spatial\Dave\SIGNAGE\SIGNAGE MANAGEMENT\Signage_2009\Script_Work_Area\"Const TechnicalPath = "\\rozelle-fp\geodata\SURVEY-SPATIAL\Spatial\ArcGIS\Stylesheets\SVGfiles\"Const CorelFileType = "CorelDRAW 2024 Graphic"Const TechnicalLayer = "Technical"Const IDLayer = "ID"
Dim SoftwareDim fsoDim SourceFolderDim FileNameDim FNameDim ActivePageDim LogDim OptDim AspectRatioDim HeightPafDim WidthDim Page
Dim Doc
Set fso = CreateObject(FileSystemObject)Set Software = CreateObject(CorelDraw)Set Opt = Software.CreateStructExportOptions
With fso Set Log = .OpenTextFile(TechnicalPath & "SVG_Export.txt", 2, True) Set SourceFolder = .GetFolder(SourcePath)
With SourceFolder For Each File in .Files With File If Right(.Name, 4) = ".cdr" Then Count = Count + 1 FileName = .Path With fso FName = fso.GetBaseName(FileName) End With
With Software.OpenDocument(FileName) .Activate .Unit = cdrMillimeter Msgbox "Drawing File Opened", vbOKOnly
With .PDFSettings .Author = "Transport for NSW (Maritime)" .Subject = "Waterway Safety Symbols" .Keywords = "Waterway Safety Symbols" .TrueTypeToType1 = True .SubsetFonts = True .SubsetPct = 80 .BitmapCompression = 0 .JPEGQualityFactor = 100 .TextAsCurves = False .EmbedFonts = True .EmbedBaseFonts = True .CompressText = False .Encoding = 1 ' CdrPDFVBA.pdfBinary .DownsampleColor = True .DownsampleGray = True .DownsampleMono = True .ColorResolution = 200 .MonoResolution = 600 .GrayResolution = 200 .Hyperlinks = True .Bookmarks = False .Thumbnails = False .pdfVersion = 6 .CropMarks = False .RegistrationMarks = False .DensitometerScales = False .FileInformation = False .ColorMode = 3 .EmbedFile = False .OverprintBlackLimit = 95 .TextAsCurves = True .PublishRange = 2 'Only selection is exported to PDF End With
' With ExpFlt' .EmbedFont = True' .Finish' End With
Set ActivePage = .Pages.First With ActivePage.Layers .Item(IDLayer).Printable = False .Item(IDLayer).Visible = False .Item(TechnicalLayer).Printable = False .Item(TechnicalLayer).Visible = False .Item("Labels").Printable = False .Item("Labels").Visible = False .Item("Details").Visible = True .Item("Details").Printable = True End With
Set Shape = ActivePage.ActiveLayer.FindShape("Reduce Wash") If Not Shape Is Nothing Then Shape.CreateSelection Width = Shape.SizeWidth Height = Shape.SizeHeight End If
opt.SizeX = Width opt.SizeY = Height
Set ExpFlt = .ExportEx(ExportPath & "Test.svg", 1345, 2, opt, Nothing) With ExpFlt .EmbedFont = True .Finish End With Log.WriteLine Count & vbTab & ExportPath & "test.svg" Msgbox "SVG export file created", vbOKOnly
.Export ExportPath & "Test.emf", 1300, 2, opt, Nothing Log.WriteLine Count & vbTab & ExportPath & "test.emf" Msgbox "EMF export file created", vbOKOnly
.PublishToPDF ExportPath & "test.pdf" Log.WriteLine Count & vbTab & ExportPath & "Test.pdf" Msgbox "PDF export file created", vbOKOnly
' Set ExpFlt = .ExportEx(ExportPath & "Test.png", 802, 2, opt, Nothing) Set exportOptions = doc.ExportOptions.png With exportOptions .TransparentBackground = True .Resolution = 300 ' Set desired resolution End With .Export ExportPath & "Test.png", cdrPNG, exportOptions Log.WriteLine Count & vbTab & ExportPath & "Test.png" Msgbox "PNG export file created", vbOKOnly
.Close' fso.deletefile(SourcePath & FName & ".cdr") End With End If End With Next End WithEnd With
Here's a code snippet from my Quick Export macro, showing the options that I used when exporting to PNG:
Dim opt As New StructExportOptions Dim ExpFilt As ExportFilter opt.AntiAliasingType = AntiAlias opt.ImageType = cdrRGBColorImage opt.Overwrite = True opt.SizeX = cboLU_Width.LastGoodNumeric opt.SizeY = cboLU_Height.LastGoodNumeric opt.ResolutionX = cboLU_Resolution.LastGoodNumeric opt.ResolutionY = cboLU_Resolution.LastGoodNumeric opt.Transparent = chkTransparency opt.UseColorProfile = chkUseColorProfile Set ExpFilt = ActiveDocument.ExportEx(full_file_name, cdrPNG, ExportRange, opt) ExpFilt.Finish
I am requiring the script to execute outside of Corel Draw. The section of script I have so far is still generating an error message. Set ExpFlt = .ExportEx(ExportPath & "Test.png", cdrPNG, cdrSelection, opt)With ExpFlt .FinishEnd With Msgbox "PNG Export File Created", vbOKOnly