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

tohaa · 30.05.2023

Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.

_MBK_ · 30.05.2023

Какие готовые?
ColorReplace отсюда, например

DukereD · 30.05.2023

tohaa сказал(а):
Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.

загоняете найденный цвет в массив и каждый новый объект проверяете и добавляете если такого элемента нет в массиве.
есть функция .tostring или можно использовать .hexvalue

tohaa · 01.06.2023

Мне тут чат жпт написал код) вроде даже вполне логично изложил, НО у него явно проблема с findshapes.
Помогите дописать правильно)

Код:

Sub GroupObjectsByColor()
'Переменные для хранения информации о цвете объекта
Dim cyan As Long
Dim magenta As Long
Dim yellow As Long
Dim black As Long
Dim objColor As String

'Переменная для объектов, которые будут группироваться
Dim groupObj As ShapeRange

'Переменная для текущего выделенного объекта
Dim currObj As shape

'Setup переменных
Set groupObj = ActiveSelection.Shapes.All()

'Проходим по всем выделенным объектам и находим объекты с одинаковыми цветами
For Each currObj In ActiveSelection.Shapes.All()
    With currObj.Fill
        cyan = .UniformColor.CMYKCyan
        magenta = .UniformColor.CMYKMagenta
        yellow = .UniformColor.CMYKYellow
        black = .UniformColor.CMYKBlack
        objColor = cyan & "," & magenta & "," & yellow & "," & black
              
    End With
    
    'Если цвет объекта уже был добавлен в группу, то игнорируем его
    If InStr(groupObj, objColor) <> 0 Then
        GoTo NextShape
    Else
        'Добавляем объекты с одинаковым цветом в группу
        groupObj.AddRange currObj.FindShapes(Type:=cdrFillShape, _
            Fill:=cmyk(cyan, magenta, yellow, black))
        'Записываем цвет объектов в примечание группы
        groupObj.AddNote objColor
    End If
    
NextShape:
Next currObj

'Группируем найденные объекты
groupObj.Group
End Sub

_MBK_ · 01.06.2023

tohaa сказал(а):
вроде даже вполне логично изложил,

Логично для кого - для тех кто ни разу на VBA не кодил? Для остальных этот говнокод - просто кровь из глаз

Любая продукция chatGPT сто лет назад охарактеризована классиками: очень похож на настоящий двигатель, но не работал

eugeny · 01.06.2023

tohaa сказал(а):
Мне тут чат жпт написал код) вроде даже вполне логично изложил, НО у него явно проблема с findshapes.
Помогите дописать правильно)

groupObj.AddRange currObj.FindShapes(Type:=cdrFillShape, _
Fill:=cmyk(cyan, magenta, yellow, black))

Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?

DukereD · 01.06.2023

eugeny сказал(а):
Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?

чего он только не придумывает... и константы и методы. он хорош в написании сказок, а не кода на VBA. Да. там где большая выборка в сети была типа страничку написать или яваскрипт он намного лучше код пишет. но вот с макросами у него проблема. квадратик в документе нарисовать еще сможет но что-то серьезное не получается у него.

_MBK_ · 01.06.2023

Когда у chatGPT не хватает знаний относительно API, он берет их не из референса (что сделал бы живой кодер) а из похожих (статистически) фрагментов кода, неважно, на каком языке, правильных или совсем безумных

_MBK_ · 01.06.2023

Еще такой момент: поскольку на питоне и браузерном js кодит сейчас каждый неленивый школьник и норовит выложить свое helloworld в сеть, соответственно, база фрагментов данного говнокода у chatGPT просто неисчерпаема. Однако с адобовским js и кореловским vba ситуация на порядок грустнее. В итоге складывается такая ситуация, что найти самому и причесать нужный фрагмент гораздо быстрее и правильнее, чем поручить данное действо злому роботу, а потом ломать голову, где же он схалтурил? Самая ближайшая аналогия для специфики этого форума - векторизация изображений. В принципе, можно сделать однокнопочным трэйсом, но результат потом выкинуть и руками обрисовать.

Акулыч · 03.06.2023

tohaa сказал(а):
Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.

для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цвета

_MBK_ · 04.06.2023

Акулыч сказал(а):
для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цвета

ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.

tohaa · 04.06.2023

_MBK_ сказал(а):
ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.

Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)

_MBK_ · 04.06.2023

tohaa сказал(а):
Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий

Данная логика абсурдна по определению - вы говорите, что написать новый скрипт проще, чем разобрать документацию и готовые примеры. Тем более, максимально подходящие у вас уже есть.

tohaa сказал(а):
ваше чсв древнего пользователя форума просто смешно)

Данная argumentum ad hominem еще более смешна

Акулыч · 04.06.2023

tohaa сказал(а):
Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)

Тут просто не совсем понятно что вам в итоге нужно. Если нужно, чтобы вам кто-то написал готовый код - это одно. Если нужно объяснить, как реализуется какой-то отдельный момент, сравнение по цвету, группировка или перебор шейпов - это совсем другое. Например, вы написали свой код и что-то там у вас в каком-то месте не работает. Код, предложенный нейросетью - косячный и можете сразу от него избавиться.

tohaa · 20.11.2023

Добрый вечер. Создаю палитру на основе выбранных объектов.
Сравниваю цвет каждого объекта с именем цвета в палитре.
А дальше не могу понять как сделать группу из объектов одного цвета.
Подскажите, научите. Еще и комунити кореловское не работает который день...

Код:

Dim s As Shape
Dim sr 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 '  перебор каждого шейпа в выделении         
                      
            If s.Fill.UniformColor.IsSame(CSColor) Then ...добавить объект в группу с тем же цветом.
            

        Next s


Next CSColor

DukereD · 20.11.2023

тут конечно удобней JS с ассоциативным массивом .
в VB приходится извращаться делать два массива один с индексами (именами цветов)
второй со значениями (ShapeRange)

после добавления по всем шейпренджам пробежаться и сгруппировать

tohaa · 20.11.2023

DukereD сказал(а):
тут конечно удобней JS с ассоциативным массивом .
в VB приходится извращаться делать два массива один с индексами (именами цветов)
второй со значениями (ShapeRange)

после добавления по всем шейпренджам пробежаться и сгруппировать

вот смотри. У меня получается создать слои по имени цветов палитры и переместить туда соответствующие цветам объекты.
но мне их нужно еще сгруппировать и вернуть на основной слой.
кажется, это слишком долгий путь.

как отправить объекты в группы вместо отправки на новый слой?

Код:

Sub blockcvet()


ActiveDocument.Unit = cdrMillimeter
ActiveDocument.ReferencePoint = cdrCenter
Application.Optimization = True
Dim s As Shape
Dim sr As New ShapeRange
Dim CSLayer As Layer
Dim CStext As String



   Set sr = ActiveSelectionRange.Shapes.FindShapes(query:="@type!='group'", Recursive:=True)
 
   'sr.UngroupAll


   
    If sr.Count = 0 Then
    MsgBox "Nothing selected!"
    Application.Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
    Exit Sub
    End If


    For Each s In sr.Shapes
    If s.Fill.UniformColor.IsSpot Then
 
        If Not s.Fill.Type = cdrNoFill Then 'esli object ne imeet zalivki - ignorirovat konvertaciu
        s.Fill.UniformColor.ConvertToCMYK
        End If
        If Not s.Outline.Type = cdrNoOutline Then ' esli object ne imeet obvodki - ignorirovat konvertaciu
            s.Outline.color.ConvertToCMYK
         
            End If
            End If
    Next s
 

 
 
 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)
     
        For Each s In sr.Shapes ' perebor kagdogo shape v videlenii
         
            If s.Fill.UniformColor.IsSame(CSColor) Then s.MoveToLayer CSLayer

        Next s


Next CSColor


CSPalette.Delete
Application.Optimization = False
ActiveWindow.Refresh
Application.Refresh

End Sub

DukereD · 21.11.2023

tohaa сказал(а):
как отправить объекты в группы вместо отправки на новый слой?

в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой

tohaa · 21.11.2023

DukereD сказал(а):
в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой

Очень ресурсоёмкая оказалась операция..

tohaa · 21.11.2023

DukereD сказал(а):
в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой

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

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

Участник

Пикирующий бомбардировщик

макрософил

Участник

Пикирующий бомбардировщик

макрософил

Пикирующий бомбардировщик

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Участник

макрософил

Участник

макрософил

Участник

Участник