[CDR 2025] Обводка под объект

[izrukvruki]

Текст с обводкой при переводе в кривые иногда разбивается на несколько объектов, и обводка одного объекта перекрывает другой объект.
Написал простенький макрос, который разбивает текст с обводкой на два объекта - без обводки и под ним обводка.

Sub dubl_contor()
    ActiveDocument.BeginCommandGroup "Обводку под объект"
    Dim sr As ShapeRange
    Dim shcopy As Shape
    Dim shOriginal As Shape
    If ActiveSelectionRange Is Nothing Then
        MsgBox ("Ничего не выделено...")
        Exit Sub
            Else
        Set sr = ActiveSelectionRange
    End If
    For Each shOriginal In sr
        If shOriginal.Outline.Width <> 0 Then 'Проверка - есть ли обводка
            ' Создаём копию
            Set shcopy = shOriginal.Duplicate
            ' Смещаем копию под оригинал
            shcopy.OrderBackOne
            ' цвет заливки - как цвет обводки
            shcopy.Fill.UniformColor.CopyAssign shcopy.Outline.Color
            ' Убираем обводку у оригинала
            shOriginal.Outline.Width = 0
        End If
    Next shOriginal
    ActiveDocument.EndCommandGroup
End Sub

 

[izrukvruki]

Поспешил я маленько... подправил..

Sub dubl_contor()
    ActiveDocument.BeginCommandGroup "Обводку под объект"
    Dim sr As ShapeRange
    Dim shcopy As Shape
    Dim shOriginal As Shape
    If ActiveSelectionRange.Count = 0 Then
        MsgBox ("Ничего не выделено...")
        Exit Sub
            Else
        Set sr = ActiveSelectionRange
    End If
    For Each shOriginal In sr
        If shOriginal.Outline.Width <> 0 Then 'Проверка - есть ли обводка
            ' Создаём копию
            Set shcopy = shOriginal.Duplicate
            ' Смещаем копию под оригинал
            shcopy.OrderBackOne
            ' цвет заливки - как цвет обводки
            shcopy.Fill.UniformColor.CopyAssign shcopy.Outline.Color
            ' Убираем обводку у оригинала
            shOriginal.Outline.Width = 0
        End If
    Next shOriginal
    ActiveDocument.EndCommandGroup
End Sub

 

[dastin]

хм ... а как же это?

... а ... и я поспешил ... ведь переводим ещё в кривые
Тогда - да. Пригодится.

 

[Акулыч]

Если цвет обводки у всех объектов одинаковый, то можно обойтись без цикла:
Private Sub test()
Dim sr As ShapeRange, sr1 As ShapeRange
Set sr = ActiveSelectionRange
If sr.Count > 0 Then
Set sr1 = sr.Duplicate
sr1.OrderBackOf sr.FirstShape
sr1.ApplyUniformFill sr.FirstShape.Outline.Color
sr.SetOutlineProperties 0
End If
End Sub

 

[mnemonix]

Надо посмотреть - бывают такие задачи.

 

[izrukvruki]

Проблема будет, если например текстовый объект имеет разную обводку - одно слово красная обводка, другое - например красное... Все окрасится наверное красным.

 

[mnemonix]

Нужен эксперимент.