загоняете найденный цвет в массив и каждый новый объект проверяете и добавляете если такого элемента нет в массиве.Здравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.
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
Логично для кого - для тех кто ни разу на VBA не кодил? Для остальных этот говнокод - просто кровь из глазвроде даже вполне логично изложил,
Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?Мне тут чат жпт написал код) вроде даже вполне логично изложил, НО у него явно проблема с findshapes.
Помогите дописать правильно)
groupObj.AddRange currObj.FindShapes(Type:=cdrFillShape, _
Fill:=cmyk(cyan, magenta, yellow, black))
чего он только не придумывает... и константы и методы. он хорош в написании сказок, а не кода на VBA. Да. там где большая выборка в сети была типа страничку написать или яваскрипт он намного лучше код пишет. но вот с макросами у него проблема. квадратик в документе нарисовать еще сможет но что-то серьезное не получается у него.Ну еще бы: cdrFillShape. chatGPT придумывает константы? или я просто про нее не знал?
для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цветаЗдравствуйте. Необходимо найти в выделении объекты одинакового цвета и комбинировать или группировать их. Искал, нашел готовые, но хотелось бы увидеть код и приемы для поиска одинаковых цветов.
ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.для начала почитайте про методы объекта Color. Там есть функция IsSame, ею можно проверять на одинаковость цвета
Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)ТС хочет волшебную кнопку. Ему были предложены развернутые примеры аналогичного софта с исходниками - просто вытащить нужное и убрать лишнее. Он предпочел робота. No comments.
Данная логика абсурдна по определению - вы говорите, что написать новый скрипт проще, чем разобрать документацию и готовые примеры. Тем более, максимально подходящие у вас уже есть.Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий
Данная argumentum ad hominem еще более смешнаваше чсв древнего пользователя форума просто смешно)
Тут просто не совсем понятно что вам в итоге нужно. Если нужно, чтобы вам кто-то написал готовый код - это одно. Если нужно объяснить, как реализуется какой-то отдельный момент, сравнение по цвету, группировка или перебор шейпов - это совсем другое. Например, вы написали свой код и что-то там у вас в каком-то месте не работает. Код, предложенный нейросетью - косячный и можете сразу от него избавиться.Что хочет тс написано в первом сообщении. Выискивать нужный код из готовых скриптов для меня сложнее, чем написать новый или найти максимально подходящий. ваше чсв древнего пользователя форума просто смешно)
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
вот смотри. У меня получается создать слои по имени цветов палитры и переместить туда соответствующие цветам объекты.тут конечно удобней 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
как отправить объекты в группы вместо отправки на новый слой?
Очень ресурсоёмкая оказалась операция..в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой
Подскажите как объединить объекты после переноса на слой. И вернуть их на начальный слой.в группу к сожалению никак нельзя отправить..
а вот кидать на слой - это в целом норм идея.
выбирать потом все объекты этого слоя, группировать и перемещать уже объект (группа как один объект) на исходный слой