[CDR 2022] Разложить контуры на разные слои

  • Автор темы Автор темы Captive
  • Дата начала Дата начала
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
Добрый день.
Помогите пожалуйста с вопросом в написании макроса.

Проблема заключается в следующем; при создании нескольких контуров объекта есть необходимость разложить их на разные слои. Но как прописать данное действие в макросе не могу разобраться. Заранее благодарен.
 
Для начала разделить контурную группу на коллекцию шейпов.
Затем каждый шейп закинуть на свой слой.
Какое именно действие является проблемой?
 
  • Спасибо
Реакции: Captive
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
For Each S In OrigSelection


' Recorded 20.05.2022
' Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim lr1 As Layer
Set lr1 = ActivePage.CreateLayer("Слой 2")
Dim lr2 As Layer
Set lr2 = ActivePage.CreateLayer("Слой 3")
Dim lr3 As Layer
Set lr3 = ActivePage.CreateLayer("Слой 4")
Dim lr4 As Layer
Set lr4 = ActivePage.CreateLayer("Слой 5")
Dim lr5 As Layer
Set lr5 = ActivePage.CreateLayer("Слой 6")
Dim lr6 As Layer
Set lr6 = ActivePage.CreateLayer("Слой 7")
Dim lr7 As Layer
Set lr7 = ActivePage.CreateLayer("Слой 8")


Dim eff1 As Effect
Set eff1 = S.CreateContour(0, 2.362205, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
eff1.Contour.ContourGroup.AddToSelection
ActiveSelection.Separate

ActivePage.Layers("Слой 1").Activate
ActiveLayer.Shapes(1).MoveToLayer lr1
lr1.Shapes.All.CreateSelection
ActiveSelection.OrderToFront

Dim eff2 As Effect
Set eff2 = S.CreateContour(0, 2.480315, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff2.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate

ActiveLayer.Shapes(1).MoveToLayer lr2
lr2.Shapes.All.CreateSelection
ActiveSelection.OrderToFront

Dim eff3 As Effect
Set eff3 = S.CreateContour(0, 3.110236, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff3.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate

ActiveLayer.Shapes(1).MoveToLayer lr3
lr3.Shapes.All.CreateSelection
ActiveSelection.OrderToFront

Dim eff4 As Effect
Set eff4 = S.CreateContour(0, 3.543307, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff4.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate


ActiveLayer.Shapes(1).MoveToLayer lr4
lr4.Shapes.All.CreateSelection
ActiveSelection.OrderToFront


Dim eff5 As Effect
Set eff5 = S.CreateContour(1, 0.23622, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff5.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate

ActiveLayer.Shapes(2).MoveToLayer ActivePage.Layers("Слой 6")
ActivePage.Layers("Слой 6").Shapes.All.CreateSelection
ActiveSelection.OrderToFront

Dim eff6 As Effect
Set eff6 = S.CreateContour(1, 0.238189, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff6.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate

ActiveLayer.Shapes(2).MoveToLayer ActivePage.Layers("Слой 7")
ActivePage.Layers("Слой 7").Shapes.All.CreateSelection
ActiveSelection.OrderToFront

ActiveLayer.Shapes.All.CreateSelection
ActiveSelection.MoveToLayer ActivePage.Layers("Слой 8")
ActiveSelection.OrderToFront

' Recorded 20.05.2022
' Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange


Next S
 
Подскажите верно ли прописаны действия?
 
Меня смущают последние 2 слоя
 
Captive сказал(а):
Подскажите верно ли прописаны действия?
Нажмите, чтобы раскрыть...
Общий принцип верен
После
ActiveSelection.Separate
организуете цикл по всем образовавшимся шейпам и в нем
Shapes(i).MoveToLayer ActivePage.Layers(i)
 
  • Спасибо
Реакции: Captive
Не совсем понимаю как создать цикл по всем образовавшимся шейпам?(((
 
Пребывая в настоящий момент вдали от корела, попробую примерно обьяснить на пальцах:
Код: 
ActiveSelection.Separate
for i=1 to ActiveSelection.Shapes.Count
 ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i)
next i
Но безошибочное выполнение не гарантирую
 
  • Спасибо
Реакции: mnemonix и Captive
Sub Previum_6_kol_min1()

Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
For Each S In OrigSelection


' Recorded 20.05.2022
' Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim lr1 As Layer
Set lr1 = ActivePage.CreateLayer("Слой 2")
Dim lr2 As Layer
Set lr2 = ActivePage.CreateLayer("Слой 3")
Dim lr3 As Layer
Set lr3 = ActivePage.CreateLayer("Слой 4")
Dim lr4 As Layer
Set lr4 = ActivePage.CreateLayer("Слой 5")
Dim lr5 As Layer
Set lr5 = ActivePage.CreateLayer("Слой 6")
Dim lr6 As Layer
Set lr6 = ActivePage.CreateLayer("Слой 7")
Dim lr7 As Layer
Set lr7 = ActivePage.CreateLayer("Слой 8")


Dim eff1 As Effect
Set eff1 = S.CreateContour(0, 2.362205, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
eff1.Contour.ContourGroup.AddToSelection
ActiveSelection.Separate




For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i)
Next i




Dim eff2 As Effect
Set eff2 = S.CreateContour(0, 2.480315, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff2.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate




For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i)
Next i
 
Он перемещает не в слои а в "направляющию"...
 
приложение
 

Вложения

  • 1.png
    1.png
    24.1 КБ · Просм.: 137
Captive сказал(а):
Dim eff2 As Effect
Set eff2 = S.CreateContour(0, 2.480315, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff2.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate




For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i)
Next i
Нажмите, чтобы раскрыть...
Вот эту часть в конце убрать вообще

Цикл попробуйте вот так переделать

For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes( i ).MoveToLayer ActivePage.Layers( i+1 )
Next i
 
  • Спасибо
Реакции: Captive
Что именно убрать нужно?
 
Изменения цикла не помогло все равно делает тоже самое
 
Сейчас вот такой момент происходит
 

Вложения

  • 2.png
    2.png
    18.6 КБ · Просм.: 143
Captive сказал(а):
перемещает не в слои а в
Нажмите, чтобы раскрыть...
попробуйте так
Код: 
Sub sh2lay()
Dim OrigSelection As ShapeRange

' тут что-то для разделения контуров и эффектов

Set OrigSelection = ActiveSelectionRange
For i = 1 To OrigSelection.Shapes.Count
 ActivePage.CreateLayer "Layer" & i
 OrigSelection.Shapes(i).MoveToLayer ActivePage.Layers(2)
Next i
End Sub
 
  • Спасибо
Реакции: mnemonix, Captive и _MBK_
For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i + 1)
Next i




Dim eff2 As Effect
Set eff2 = S.CreateContour(0, 2.480315, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff2.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate



For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i + 2)
Next i



Dim eff3 As Effect
Set eff3 = S.CreateContour(0, 3.110236, 1, 0, CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), CreateCMYKColor(0, 0, 0, 100), 0, 0, 2, 4, 15#)
ActiveDocument.CreateSelection eff3.Contour.ContourGroup, OrigSelection
ActiveSelection.Separate



For i = 1 To ActiveSelection.Shapes.Count
ActiveSelection.Shapes(i).MoveToLayer ActivePage.Layers(i + 3)
Next i
 
Вот так все работает!!!
Приношу извинения за некорректный ответ сразу.
 
Спасибо огромное за помощь
 
Для ответа нужно войти/зарегистрироваться
Верх Низ