Corel Draw: как обрезать объекты в контейнере

30/8/2024

Как обрезать объекты в кореле, находящиеся в контейнере (Powerclip)? Это может понадобиться для удобного наложения и просмотра в каркасном режиме или для плоттерной резки. Создадим для этого скрипт, который выполнит всю работу за нас.

Итак, в качестве примера я взял объекты разных типов: растровая картинка, текст и паттерн из векторных кружочков.

Красный квадрат, это будет наш контейнер — PowerClip. Помещаем все объекты в контейнер.

внизу надпись, что прямоугольник является контейнером

Выделяем контейнер, запускаем наш макрос, который напишем ниже, и получаем результат:

Я удалил красный прямоугольник, так как он уже не нужен

Как видите, у нас здесь выделено 44 объекта, обрезанных по контуру контейнера. Вот, как это выглядит в каркасном режиме (wireframe):

Вернемся к нашему макросу. Начнем с процедуры запуска и проверки наличия выделения.

Sub deletePowerClip()
Dim sHr
Set sHr = ActiveSelectionRange
If sHr.Count = 0 Then
    MsgBox "Ничего не выбрано.": Exit Sub
End If
ActiveDocument.BeginCommandGroup "Extract AND Cut PowerClip"
Call cut_deletePowerClip(sHr)
ActiveDocument.EndCommandGroup

End Sub

Здесь все просто. Проверяем есть ли выделение и группируем последующие действия в одну группу Extract AND Cut PowerClip — это для undo операции. Теперь перейдем к вызову функции cut_deletePowerClip.

Function cut_deletePowerClip(sHr)
    Dim shir As Long, sizCoord, sh As Shape, delta, crestSize, srAll As ShapeRange, color As color, newColor
    Dim shrExtr As ShapeRange, res As Shape, coordPC, duplicat As Shape, screenREctor  As Shape, delSHR As ShapeRange
    Dim endselectR As New ShapeRange
    endselectR.AddRange sHr

Set srAll = findOnlyPowerClip(sHr)
Do While Not srAll Is Nothing And srAll.Count <> 0
    Set sh = srAll.Item(1)
        Set shrExtr = sh.PowerClip.ExtractShapes
        If shrExtr.Count > 0 Then
            Set color = sh.Outline.color
            coordPC = cut_getSizeCoords(sh)
            Set duplicat = sh.Duplicate
                duplicat.CreateSelection
           Application.FrameWork.Automation.InvokeItem "7b022531-3cd7-487f-a797-9d80179dc821"
            DoEvents
            Set screenREctor = duplicat.Intersect(shrExtr.Group, True, True)
            If sh.Outline.Type = cdrNoOutline Then
                duplicat.Delete
            Else
                duplicat.Outline.color = color
            End If
            
            If ShapeExists(screenREctor) Then
                screenREctor.OrderBackOf sh
                srAll.Add screenREctor
                endselectR.Add screenREctor
             End If
            shrExtr.Delete
            sh.Delete
         End If
        Set sHr = srAll.UngroupAllEx
       
 Set srAll = findOnlyPowerClip(sHr)

Loop
endselectR.CreateSelection
Set cut_deletePowerClip = endselectR
End Function

Красным выделены новые функции, которые будут ниже. Синим выделен код, который отвечает за удаление у прямоугольника свойства контейнера. Визуально это выглядит так:

Теперь вернемся к коду findOnlyPowerClip, функция, которая ищет и выбирает объекты со свойством PowerClip.

Function findOnlyPowerClip(sHr)
 Dim s As Shape
 Dim srPowerClipped As New ShapeRange, srAll As New ShapeRange
 
 Do
    For Each s In sHr.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
        srAll.Add s
    Next s
    sHr.RemoveAll
    sHr.AddRange srPowerClipped
    srPowerClipped.RemoveAll
Loop Until sHr.Count = 0

Set findOnlyPowerClip = srAll
End Function

И последняя функция cut_getSizeCoords, которая получает координаты для реза.

Function cut_getSizeCoords(sh)
Dim x As Double, y As Double, xTop As Double, yRight As Double
sh.GetSize x, y: sh.GetPosition xTop, yRight
cut_getSizeCoords = Array(x, y, xTop, yRight)
End Function

На этом всё. Для запуска используем процедуру deletePowerClip.

Режьте на здоровье!

tеги:coreldraw скрипт допечатка

Комментарии: