[CDR 2017-2021] Сгруппировать объекты по слоям с именем соответствующих слоев

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835

eugeny

15 лет на форуме
Сообщения
855
Реакции
210
Скрипт рабочий. У меня была такая фигня — перезапустите Корел.
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
  • Спасибо
Реакции: Nameless950

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 131
Реакции
2 027
перезапустите Корел
... давайте лучше не будем ... '))'

из всех слоёв для каждой из страниц документа останется
один слой с поименованными группами (названиями слоёв)
заблокированные слои останутся как есть
заблокированные объекты будут разблокированы
оставшиеся пустые слои будут удалены


Код:
Sub cmbML()
Dim pg As Page, lyr As Layer, Nlyr As String
Dim sr As ShapeRange, Asr As New ShapeRange, Lsr As Shape
Dim srNE As New ShapeRange
    Optimization = True
    EventsEnabled = False
    ActiveDocument.BeginCommandGroup "Merge_Layers"

For Each pg In ActiveDocument.Pages
pg.Activate
    For Each lyr In pg.Layers
    lyr.Activate
        If lyr.IsSpecialLayer = False Then
        If lyr.Editable = False Then GoTo nonE:
            Nlyr = lyr.Name
        Set srNE = lyr.Shapes.FindShapes(Query:="@com.locked = 'true'")
        srNE.Unlock
        Set sr = lyr.Shapes.All
            If sr.Count <> 0 Then
            Set Lsr = sr.Group
            Lsr.Name = Nlyr
            Asr.Add Lsr
            Else
            lyr.Delete
            End If
        End If
nonE:
    Next
    Asr.Group
    Asr.RemoveAll
  
    For Each lyr In pg.Layers
    lyr.Activate
        If lyr.IsSpecialLayer = False Then
        Set sr = lyr.Shapes.All
            If sr.Count = 0 Then
            lyr.Delete
            End If
        End If
    Next
Next

    ActiveDocument.EndCommandGroup
   Application.FrameWork.Automation.Invoke "3be0149d-d861-4fcf-ba5b-724554af2376"
   Application.FrameWork.Automation.Invoke "e6627fc9-9497-4ca9-b3ac-808b91666131"
   DoEvents
    EventsEnabled = True
    Optimization = False
    Refresh
End Sub
 
Последнее редактирование:

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835

DukereD

макрософил
Сообщения
458
Реакции
111

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 131
Реакции
2 027
Последнее редактирование:
  • Спасибо
Реакции: DukereD

DukereD

макрософил
Сообщения
458
Реакции
111
переключение отображения страниц и слоёв - туда и обратно - для обновления информации
в старых и последних версиях

Посмотреть вложение 151829Посмотреть вложение 151831
а может кто знает как заставить значок "сохранять пропорции" перерисовываться, а то на горячую клавишу поставил. оно то работает но визуально не видно. сработало или нет. только после того как поменять какой-то размер оно перерисовывает панель инструментов.