Hi guys I have a macro to curves barcodes on X7. It was working on X4. I tried to change for x7 but when i wrote last line it shut corel down. Could you help me please. I am new for vba :)

Option Explicit

Sub barkodkonvertx7()
Dim sr As New ShapeRange, sh As Shape, expF As ExportFilter, colorWHITE 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, "BARCODE") 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)
With 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 With
NextBar:
Err.Clear
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 Exit Sub
ActiveDocument.BeginCommandGroup "BARCODE combine curves"
On Error GoTo NextShape
colorWHITE.CMYKAssign 0, 0, 0, 0
toDEL.RemoveAll
For Each sr 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 bars
Next sr
toDEL.Add sr.Combine
NextShape:
Err.Clear
ActiveDocument.EndCommandGroup
toDEL.CreateSelection
Else
End If
Next
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 = 1
End With
End Function

  • Code below finds all OLE objects (on active page) with part of name „BARCODE“ and convert them to curves (text is also convereted to curves)

     

    Sub BarcodeToCurves()
        Dim OrigSelection As ShapeRange, bc As ShapeRange, sx#, sy#, s1 As Shape
        ActiveDocument.BeginCommandGroup ("BARCODE")
        On Error GoTo ErrHandler
        Optimization = True
        Set bc = ActivePage.FindShapes(, cdrOLEObjectShape)
        For Each s1 In bc
        If InStr(s1.OLE.FullName, "BARCODE") Then
          s1.GetPosition sx, sy
          s1.Cut
          ActiveLayer.PasteSpecial "Metafile"
          Set pastesel = ActiveSelectionRange
          pastesel.PositionX = sx
          pastesel.PositionY = sy
          pastesel.Ungroup
          For Each s In pastesel
          If s.ZOrder = pastesel.Count Then s.Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 0): GoTo here
          s.Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
          If s.Type = cdrTextShape Then s.ConvertToCurves
    here:
          Next s
          pastesel.CreateSelection
          pastesel.Group
          End If
          Next s1
          Optimization = False
          ActiveDocument.EndCommandGroup
    ExitSub:
    Optimization = False
    ActiveWindow.Refresh
    Exit Sub

    ErrHandler:
     MsgBox "Error occured: " & Err.Description
     Resume ExitSub
    End Sub

     

    Best regards,

     

    Mek

     

    • Thanks a lot. But there is an error on the "On error GoTo ErrHAndler" line. (Label not defined)
      I am trying to solve this issue but i don't say no for your helps :)