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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Какие готовые?
ColorReplace отсюда, например
 

DukereD

макрософил
Сообщения
482
Реакции
116
Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.
загоняете найденный цвет в массив и каждый новый объект проверяете и добавляете если такого элемента нет в массиве.
есть функция .tostring или можно использовать .hexvalue
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Мне тут чат жпт написал код) вроде даже вполне логично изложил, НО у него явно проблема с 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_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
вроде даже вполне логично изложил,
Логично для кого - для тех кто ни разу на VBA не кодил? Для остальных этот говнокод - просто кровь из глаз :D
Любая продукция chatGPT сто лет назад охарактеризована классиками: очень похож на настоящий двигатель, но не работал :D
 
  • Спасибо
Реакции: romyk

eugeny

15 лет на форуме
Сообщения
886
Реакции
217
Мне тут чат жпт написал код) вроде даже вполне логично изложил, НО у него явно проблема с findshapes.
Помогите дописать правильно)

groupObj.AddRange currObj.FindShapes(Type:=cdrFillShape, _
Fill:=cmyk(cyan, magenta, yellow, black))
Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?
 

DukereD

макрософил
Сообщения
482
Реакции
116
Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?
чего он только не придумывает... и константы и методы. он хорош в написании сказок, а не кода на VBA. Да. там где большая выборка в сети была типа страничку написать или яваскрипт он намного лучше код пишет. но вот с макросами у него проблема. квадратик в документе нарисовать еще сможет но что-то серьезное не получается у него.
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Когда у chatGPT не хватает знаний относительно API, он берет их не из референса (что сделал бы живой кодер) а из похожих (статистически) фрагментов кода, неважно, на каком языке, правильных или совсем безумных
 
  • Спасибо
Реакции: ~RA~ и DukereD

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Еще такой момент: поскольку на питоне и браузерном js кодит сейчас каждый неленивый школьник и норовит выложить свое helloworld в сеть, соответственно, база фрагментов данного говнокода у chatGPT просто неисчерпаема. Однако с адобовским js и кореловским vba ситуация на порядок грустнее. В итоге складывается такая ситуация, что найти самому и причесать нужный фрагмент гораздо быстрее и правильнее, чем поручить данное действо злому роботу, а потом ломать голову, где же он схалтурил? Самая ближайшая аналогия для специфики этого форума - векторизация изображений. В принципе, можно сделать однокнопочным трэйсом, но результат потом выкинуть и руками обрисовать.
 
  • Спасибо
Реакции: DukereD, Chiga и Drawer

Акулыч

Участник
Сообщения
34
Реакции
10
Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.
для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цвета
 
  • Спасибо
Реакции: zollinger и DukereD

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цвета
ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.
Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий
Данная логика абсурдна по определению - вы говорите, что написать новый скрипт проще, чем разобрать документацию и готовые примеры. Тем более, максимально подходящие у вас уже есть.

ваше чсв древнего пользователя форума просто смешно)
Данная argumentum ad hominem еще более смешна
 

Акулыч

Участник
Сообщения
34
Реакции
10
Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)
Тут просто не совсем понятно что вам в итоге нужно. Если нужно, чтобы вам кто-то написал готовый код - это одно. Если нужно объяснить, как реализуется какой-то отдельный момент, сравнение по цвету, группировка или перебор шейпов - это совсем другое. Например, вы написали свой код и что-то там у вас в каком-то месте не работает. Код, предложенный нейросетью - косячный и можете сразу от него избавиться.
 

tohaa

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

Код:
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

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

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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
тут конечно удобней 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

1700510897764.png
 
Последнее редактирование:

DukereD

макрософил
Сообщения
482
Реакции
116
как отправить объекты в группы вместо отправки на новый слой?

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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой
Очень ресурсоёмкая оказалась операция..
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой
Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.