[CDR 2017-2021] Поиск и группировка одинаковых цветов в выделении.

[_MBK_]

Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.

Создать из них ShapeRange, затем его сделать Group и полученную группу обратно на начальный слой.
Причем для первого шага вовсе не обязательно новый слой запиливать, это лишнее звено технологической цепочки.

 

[tohaa]

Создать из них ShapeRange, затем его сделать Group и полученную группу обратно на начальный слой.
Причем для первого шага вовсе не обязательно новый слой запиливать, это лишнее звено технологической цепочки.

Вы правы. В цикле для каждого цвета из созданной палитры создаю слой с именем "work". Перемещаю объекты подходящео цвета по очереди на этот слой. Далее группирую их и переношу на основной слой. Временный слой удаляю.
Работает! Спасибо

..

Dim CSColor As color
Dim sgr As ShapeRange
    
    For Each CSColor In CSPalette.colors

        CStext = CSColor.Name(True)
        
        Set CSLayer = ActivePage.CreateLayer("work")
        
        For Each s In sr.Shapes ' perebor kagdogo shape v videlenii
            
            If s.Fill.UniformColor.IsSame(CSColor) Then s.MoveToLayer CSLayer
            Set so = s.Fill.UniformColor
s.Outline.SetProperties 0.1, , so, , , , , cdrOutlineRoundLineCaps, cdrOutlineRoundLineJoin


        Next s
CSLayer.Shapes.All.Group
CSLayer.Shapes.All.MoveToLayer mainLayer
CSLayer.Delete

Next CSColor

 

[_MBK_]

Я все таки не понимаю, зачем вам заморочки с лишним слоем, почему нельзя просто ShapeRange обойтись?

 

[tohaa]

Подскажите пожалуйста, а возможно присвоить имя группе объектов?

 

[tohaa]

Я все таки не понимаю, зачем вам заморочки с лишним слоем, почему нельзя просто ShapeRange обойтись?

я не разобрался как группировать цвета в shaperange.

 

[tohaa]

Подскажите пожалуйста, а возможно присвоить имя группе объектов?

Сам спросил - сам ответил)

.Group.ObjectData("Name").Value = "имя группы"

Dim CSPalette As Palette
    
    Set CSPalette = Palettes.CreateFromSelection("BlockColors", , True) 'sozdal palitru
    
Dim CSColor As color
Dim sgr As ShapeRange
    
    For Each CSColor In CSPalette.colors

        CStext = CSColor.Name(True)
        'Set CSLayer = ActivePage.CreateLayer(CStext)
        Set CSLayer = ActivePage.CreateLayer("work")
        
        For Each s In sr.Shapes ' perebor kagdogo shape v videlenii
            
            If s.Fill.UniformColor.IsSame(CSColor) Then s.MoveToLayer CSLayer
                Set so = s.Fill.UniformColor
                s.Outline.SetProperties 0.1, , so, , , , , cdrOutlineRoundLineCaps, cdrOutlineRoundLineJoin

        Next s
CSLayer.Shapes.All.Group.ObjectData("Name").Value = CStext
CSLayer.Shapes.All.MoveToLayer mainLayer
CSLayer.Delete

Next CSColor


CSPalette.Delete

 

[DukereD]

Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.

самый удобный способ, который я сразу описывал это раскладывать каждый цвет в свой ShapeRange тогда не нужно никуда переносить.
ну и потом каждый шейпрендж MoveToLayer

еще можно попробовать сначала один раз пробежать по всем объектам и записать все уникальные цвета в массив.
потом пробежаться по этому массиву и выборкой через
FindShapes(query:=query, Recursive:=True).Group
сразу группировать

 

[_MBK_]

и потом каждый шейпрендж MoveToLayer

Зачем? Сразу группировать ShapeRange

 

[tohaa]

Подскажите как правильно группировать. Сейчас все цвета попадают в одну группу. Хотя группы с названием цвета создаются нормально.

ActiveDocument.Unit = cdrMillimeter



Dim s As shape

Dim gr As New ShapeRange

Dim CStext As String

   Set sr = ActiveSelectionRange.Shapes.FindShapes(query:="@type!='group'", Recursive:=True)
  
 Dim CSPalette As Palette
    
    Set CSPalette = Palettes.CreateFromSelection("BlockColors", , True) 'sozdal palitru
    
Dim CSColor As color

    For Each CSColor In CSPalette.colors

        CStext = CSColor.Name(True)

        For Each s In sr.Shapes ' perebor kagdogo shape v videlenii
        
        Set so = s.Fill.UniformColor
        s.Outline.SetProperties 0.1, , so, , , , , cdrOutlineRoundLineCaps, cdrOutlineRoundLineJoin
                      
             If s.Fill.UniformColor.IsSame(CSColor) Then gr.Add s
        
        Next s
        gr.Group.ObjectData("Name").Value = CStext

Next CSColor

Зачем? Сразу группировать ShapeRange

 

[_MBK_]

Ну так правильно, у вас шейпранг создается один единственный gr в самом начале и все шейпы валятся в него. А надо проверять по какому нибудь признаку создан ли шейпранг с таким цветом или нет, если нет то создавать. Так же как со слоями. Ну или в цикле по цветам каждый раз новый шейпранг создавать и в конце группировать.

 

[DukereD]

Зачем? Сразу группировать ShapeRange

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

 

[tohaa]

Появилась неприятная особенность после выполнения этого макроса. Стоит сразу после выполнения макроса нажать кнтрл-z и корел мгновенно вылетает. Пробовал в разных версиях корела - повторяемость 100%. Может кто-нибудь сталкивался с такой бедой и знает как решить?

 

[DukereD]

Появилась неприятная особенность после выполнения этого макроса. Стоит сразу после выполнения макроса нажать кнтрл-z и корел мгновенно вылетает. Пробовал в разных версиях корела - повторяемость 100%. Может кто-нибудь сталкивался с такой бедой и знает как решить?

после какого макроса? )
очень часто такое бывает когда между слоями объекты перекидываются.
ну и конечно же неплохо бы в начале добавить

ActiveDocument.BeginCommandGroup

а в конце

ActiveDocument.EndCommandGroup

 

[tohaa]

после какого макроса? )
очень часто такое бывает когда между слоями объекты перекидываются.
ну и конечно же неплохо бы в начале добавить

ActiveDocument.BeginCommandGroup

а в конце

ActiveDocument.EndCommandGroup

Макрос как раз переносит объекты по слоям. А куда именно размещать бегин и энд командгрупп? Перед объявлением переменных?

 

[DukereD]

Макрос как раз переносит объекты по слоям. А куда именно размещать бегин и энд командгрупп? Перед объявлением переменных?

можно и после. до первого действия которое попадает в UNDO.

эти команды "группируют" все действия для однократного Ctrl+Z

 

[tohaa]

можно и после. до первого действия которое попадает в UNDO.

эти команды "группируют" все действия для однократного Ctrl+Z

Ах вот оно что! Благодарю !