Export to EMF Macro

Const FileSystemObject = "Scripting.FileSystemObject"
Const CorelDraw = "CorelDraw.Application"
Const ExportPath = "\\rozwgismdpr0001\SURVEY-SPATIAL\Spatial\ArcGIS\Stylesheets\SVGfiles\WorkingArea\"
Const SourcePath = "\\rozwgismdpr0001\SURVEY-SPATIAL\Spatial\Dave\SIGNAGE\SIGNAGE MANAGEMENT\Signage_2009\Script_Work_Area\"
Const TechnicalPath = "\\rozwgismdpr0001\SURVEY-SPATIAL\Spatial\Dave\SIGNAGE\SIGNAGE MANAGEMENT\Signage_2009\Boating_Safety_Information\"
Const CorelFileType = "CorelDRAW 2020 Graphic"
Const TechnicalLayer = "Technical"
Const IDLayer = "ID"

Dim Software
Dim fso
Dim SourceFolder
Dim FileName
Dim FName
Dim ActivePage
Dim Log
Dim Opt
Dim AspectRatio
Dim Height
Dim Width
Dim Page

Set fso = CreateObject(FileSystemObject)
Set Software = CreateObject(CorelDraw)
Set Opt = Software.CreateStructExportOptions

With fso
 Set Log = .OpenTextFile(ExportPath & "SVG_Export.txt", 2, True)
 Set SourceFolder = .GetFolder(SourcePath)

 With SourceFolder
  For Each File in .Files
   With File
    If .Type = CorelFileType Then
     Count = Count + 1
     FileName = .Path
    
      With fso
       FName = fso.GetBaseName(FileName)
      End With

     With Software.OpenDocument(FileName)
      .Activate
      .Unit = cdrMillimeter

      With .PDFSettings
       .Author = "Roads and Maritime Services (RMS)"
       .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

      Set ActivePage = .Pages.First
       With ActivePage.Layers
        .Item(IDLayer).Printable = False
        .Item(IDLayer).Visible = False
        .Item(TechnicalLayer).Printable = False
        .Item(TechnicalLayer).Visible = False
        .Item("Details").Visible = True
        .Item("Details").Printable = True
       End With

      Set Shape = ActivePage.ActiveLayer.FindShape("Minimise Wash")
       If Not Shape Is Nothing Then
        Shape.CreateSelection
        Width = Shape.SizeWidth
        Height = Shape.SizeHeight

        AspectRatio = Width / Height
        Height = 600
        Width = AspectRatio * Height
       End If

      opt.SizeX = Width
      opt.SizeY = Height

      Set ExpFlt = .ExportEx(ExportPath & "716.svg", 1345, 2, opt, Nothing)

      With ExpFlt
       .EmbedFont = True
       .Finish
      End With
      Log.WriteLine Count & vbTab & ExportPath & "716.svg"

      Set ExpFlt = .ExportEx(ExportPath & "716.emf", 1300, 2, opt, Nothing)
      Log.WriteLine Count & vbTab & ExportPath & "716.emf"

      .PublishToPDF ExportPath & "716.pdf"
      Log.WriteLine Count & vbTab & ExportPath & "716.pdf"

     .Close
     End With
    End If
   End With
  Next
 End With
End With