Штрих-коды в кривых Corel X6

[hatrix]

Тут лежит макрос для конвертации кореловских штрих-кодов в кривые. Работает только до версии X4. Немного поковырялся в нем и подточил для X6, добавил в конце окрашивание в K100. Можно скачать тут или скопипастить ниже.
Чтобы заработал в X5 (не проверял правда) нужно найти в макросе "Corel BARCODE X6" и заменить на "Corel BARCODE X5" (должно сработать по идее).

Sub BarCodeCurves()
   Dim sr As New ShapeRange, sh As Shape, expF As ExportFilter, colorWHITE As New Color, colorBLACK As New Color
   Dim file$, toDEL As New ShapeRange, toSelect As New ShapeRange, bars&
   If ActiveDocument Is Nothing Then Exit Sub
   If ActiveShape Is Nothing Then sr.AddRange ActivePage.FindShapes(, cdrOLEObjectShape) _
      Else sr.AddRange ActiveSelection.Shapes.FindShapes(, cdrOLEObjectShape)
   If sr.Count = 0 Then Beep: Exit Sub
   ActiveDocument.BeginCommandGroup "BARCODE curves"
   On Error GoTo NextBar
   For Each sh In sr
      If InStr(sh.OLE.FullName, "Corel BARCODE X6") Then
         sh.CreateSelection: bars = bars + 1
         file = Environ("temp"): file = file + IIf(Right(file, 1) <> "\", "\", "") + Hex(Timer) + ".eps"
         Set expF = ActiveDocument.ExportEx(file, cdrEPS, cdrSelection)
         EPSOptionsLoad expF
         expF.Finish
         If FileSystem.FileLen(file) > 0 Then
            sh.Layer.Import file, cdrPSInterpreted
            If Not ActiveShape Is Nothing Then
               ActiveShape.SetPosition sh.PositionX, sh.PositionY
               ActiveShape.OrderFrontOf sh
               toDEL.Add sh
               toSelect.Add ActiveShape
               FileSystem.Kill file
            End If
         End If
      End If
NextBar:
      Err.Clear
   Next
   toDEL.Delete
   ActiveDocument.EndCommandGroup
   If toSelect.Count = 0 Then
      ActiveDocument.ClearSelection
      MsgBox IIf(bars = 0, "No BARCODES found", "Error on internal EPS export/import of BARCODE")
      Exit Sub
   End If
   toSelect.CreateSelection
   If MsgBox("Found: " + CStr(bars) + " barcodes. " + _
             IIf(bars = toSelect.Count, "EVERYTHING is curved", "Only " + CStr(toSelect.Count)) + " are curved" + vbNewLine + vbNewLine + _
             "Remove white background and combine individually?", vbYesNoCancel, "BARCODE curver") <> vbYes Then
                        colorBLACK.RGBAssign 0, 0, 0
                        For Each sh In toSelect
                         Set sr = sh.UngroupAllEx
                           For bars = 1 To sr.Count
                             If sr(bars).Fill.UniformColor.IsSame(colorBLACK) Then sr(bars).Fill.UniformColor = CreateCMYKColor(0, 0, 0, 100)
                           Next
                        Next
                        Exit Sub
                        End If
   ActiveDocument.BeginCommandGroup "BARCODE combine curves"
   On Error GoTo NextShape
   colorWHITE.RGBAssign 255, 255, 255
   toDEL.RemoveAll
   For Each sh In toSelect
      Set sr = sh.UngroupAllEx
      For bars = 1 To sr.Count
         If sr(bars).Fill.UniformColor.IsSame(colorWHITE) Then _
            sr(bars).Delete: Exit For
      Next
      toDEL.Add sr.Combine
NextShape:
      Err.Clear
   Next
   ActiveDocument.EndCommandGroup
   toDEL.CreateSelection
   ActiveSelection.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 100)
   End Sub

Private Function EPSOptionsLoad(eFlt As ExportFilter)
   With eFlt
   .AdjustFountainSteps = False: .ApplyICCProfile = False: .AutoSpread = False
    .CropMarks = False: .FixedWidth = False: .IncludeFonts = False: .MaintainOPILinks = False
    .OverprintBlack = False: .PreserveOverprints = False: .TextAsCurves = True: .Transparent = True
    .UseBleed = False: .UseFloatNumbers = True: .UseJPEGCompression = False: .UseSeparationProfile = False
   .Bleed = 0: .BoundingBox = 0: .FountainSteps = 256: .Header = 0: .MaxSpread = 0: .PSLevel = 2
   End With
   End Function

[Murik]

В Кореле до 5 включительно - делаем штрих-код (Edit - Insert Barcode), потом вырезаем (Ctr-X), потом Edit - PasteSpetial - Рисунок (метафайл) - вставляет штрихи в кривых, цифры текстом. До 14-15 корел работает.

[hatrix]

Еще один скрипт на основе метода от Murik. Добавлена оптимизация, можно выбирать кривить/не кривить шрифты в кодах.

Sub BarCodeCurves()
startoptimization
   Dim sr As New ShapeRange, sh As Shape, colorWHITE As New Color, colorBLACK As New Color
   Dim file$, toDEL As New ShapeRange, toSelect As New ShapeRange, bars&
   If ActiveDocument Is Nothing Then GoTo Finish
   If ActiveShape Is Nothing Then sr.AddRange ActivePage.FindShapes(, cdrOLEObjectShape) _
      Else sr.AddRange ActiveSelection.Shapes.FindShapes(, cdrOLEObjectShape)
   If sr.Count = 0 Then GoTo Finish
Select Case MsgBox("Convert fonts to curve?", vbYesNoCancel, "BARCODE curver")
          Case vbYes
              For Each sh In sr
               If InStr(sh.OLE.FullName, "Corel BARCODE X6") Then
                sh.CreateSelection: bars = bars + 1
                sh.Copy
                ActiveLayer.PasteSpecial "Metafile"
                ActiveShape.SetPosition sh.PositionX, sh.PositionY
                ActiveShape.OrderFrontOf sh
                Err.Clear
                toDEL.Add sh
                toSelect.Add ActiveShape
               End If
              Next
             toDEL.Delete
             toSelect.ConvertToCurves
          Case vbNo
              For Each sh In sr
               If InStr(sh.OLE.FullName, "Corel BARCODE X6") Then
                sh.CreateSelection: bars = bars + 1
                sh.Copy
                ActiveLayer.PasteSpecial "Metafile"
                ActiveShape.SetPosition sh.PositionX, sh.PositionY
                ActiveShape.OrderFrontOf sh
                Err.Clear
                toDEL.Add sh
                toSelect.Add ActiveShape
               End If
              Next
             toDEL.Delete
          Case vbCancel
             GoTo Finish
   End Select
   
   If toSelect.Count = 0 Then
      ActiveDocument.ClearSelection
      MsgBox IIf(bars = 0, "No BARCODES found", "Error on internal EPS export/import of BARCODE")
      stoptoptimization
      Exit Sub
   End If
   toSelect.CreateSelection
   If MsgBox("Found: " + CStr(bars) + " barcodes. " + _
             IIf(bars = toSelect.Count, "EVERYTHING is curved", "Only " + CStr(toSelect.Count)) + " are curved" + vbNewLine + vbNewLine + _
             "Remove white background and combine individually?", vbYesNoCancel, "BARCODE curver") <> vbYes Then
                        colorBLACK.RGBAssign 0, 0, 0
                        For Each sh In toSelect
                         Set sr = sh.UngroupAllEx
                         Err.Clear
                           For bars = 1 To sr.Count
                             If sr(bars).Fill.UniformColor.IsSame(colorBLACK) Then sr(bars).Fill.UniformColor = CreateCMYKColor(0, 0, 0, 100)
                           Next
                         Set sh = sr.Group
                        Next
                        stoptoptimization
                        Exit Sub
                        End If

   colorWHITE.RGBAssign 255, 255, 255
   toDEL.RemoveAll
   For Each sh In toSelect
      Set sr = sh.UngroupAllEx
      For bars = 1 To sr.Count
         If sr(bars).Fill.UniformColor.IsSame(colorWHITE) Then _
            sr(bars).Delete: Exit For
      Next
      toDEL.Add sr.Combine
   Next
   toDEL.CreateSelection
   ActiveSelection.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 100)
Finish:
   Err.Clear
   stoptoptimization
   End Sub

Sub startoptimization()
ActiveDocument.PreserveSelection = False
Optimization = True
EventsEnabled = False
End Sub

Sub stoptoptimization()
EventsEnabled = True
Optimization = False
ActiveDocument.PreserveSelection = True
ActiveDocument.EndCommandGroup
End Sub

[XXL]

В кореле никогда не требовались скрипты для конвертации штрих кодов в кривые.

[Александр В.]

Простите, что-то я не догоняю зачем это нужно? Что потом с этим баркодом переведенным в кривые делать?

[XXL]

Например цвет другой задать

[hatrix]

Сообщение от Александр В.

зачем это нужно

Затем, что баркоды (штрихкоды) в кореле - это OLE-объект. Собственно вот основная причина из которой потом вытекает куча других проблем. Чтоб их не было - вот скрипт.