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 NextBarFor 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 WithNextBar: 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.CombineNextShape: Err.Clear ActiveDocument.EndCommandGroup toDEL.CreateSelectionElseEnd IfNextEnd SubPrivate 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.ConvertToCurveshere: Next s pastesel.CreateSelection pastesel.Group End If Next s1 Optimization = False ActiveDocument.EndCommandGroupExitSub:Optimization = FalseActiveWindow.RefreshExit Sub
ErrHandler: MsgBox "Error occured: " & Err.Description Resume ExitSubEnd Sub
Best regards,
Mek