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

  • Автор темы Автор темы tohaa
  • Дата начала Дата начала
tohaa сказал(а):
Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.
Нажмите, чтобы раскрыть...
Создать из них ShapeRange, затем его сделать Group и полученную группу обратно на начальный слой.
Причем для первого шага вовсе не обязательно новый слой запиливать, это лишнее звено технологической цепочки.
 
  • Спасибо
Реакции: tohaa
_MBK_ сказал(а):
Создать из них 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
 
Я все таки не понимаю, зачем вам заморочки с лишним слоем, почему нельзя просто 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
 
tohaa сказал(а):
Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.
Нажмите, чтобы раскрыть...
самый удобный способ, который я сразу описывал это раскладывать каждый цвет в свой ShapeRange тогда не нужно никуда переносить.
ну и потом каждый шейпрендж MoveToLayer

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

Код: 
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
_MBK_ сказал(а):
Зачем? Сразу группировать ShapeRange
Нажмите, чтобы раскрыть...
 
Ну так правильно, у вас шейпранг создается один единственный gr в самом начале и все шейпы валятся в него. А надо проверять по какому нибудь признаку создан ли шейпранг с таким цветом или нет, если нет то создавать. Так же как со слоями. Ну или в цикле по цветам каждый раз новый шейпранг создавать и в конце группировать.
 
Последнее редактирование:
Появилась неприятная особенность после выполнения этого макроса. Стоит сразу после выполнения макроса нажать кнтрл-z и корел мгновенно вылетает. Пробовал в разных версиях корела - повторяемость 100%. Может кто-нибудь сталкивался с такой бедой и знает как решить?
 
tohaa сказал(а):
Появилась неприятная особенность после выполнения этого макроса. Стоит сразу после выполнения макроса нажать кнтрл-z и корел мгновенно вылетает. Пробовал в разных версиях корела - повторяемость 100%. Может кто-нибудь сталкивался с такой бедой и знает как решить?
Нажмите, чтобы раскрыть...
после какого макроса? )
очень часто такое бывает когда между слоями объекты перекидываются.
ну и конечно же неплохо бы в начале добавить

ActiveDocument.BeginCommandGroup

а в конце

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

ActiveDocument.BeginCommandGroup

а в конце

ActiveDocument.EndCommandGroup
Нажмите, чтобы раскрыть...
Макрос как раз переносит объекты по слоям. А куда именно размещать бегин и энд командгрупп? Перед объявлением переменных?
 
tohaa сказал(а):
Макрос как раз переносит объекты по слоям. А куда именно размещать бегин и энд командгрупп? Перед объявлением переменных?
Нажмите, чтобы раскрыть...
можно и после. до первого действия которое попадает в UNDO.

эти команды "группируют" все действия для однократного Ctrl+Z
 
  • Спасибо
Реакции: tohaa
Для ответа нужно войти/зарегистрироваться
Верх Низ