[CDR 2017-2021] Поиск групп в документе и перекрас наибольшего.

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Добрый день. Помогите пожалуйста с макросом.

Условие: В файле случайное количество объектов. Среди объектов есть группы и одиночные объекты.

Задача: Найти все группы, определить наибольший по габаритным размерам объект в каждой группе и перекрасить его красной обводкой. Группы сохранить.
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
По каким габаритным размерам наибольший?
Сдается мне, вы снова неправильно формулируете свой вопрос
наибольшим объектом считаем объект с большей площадью @shape1.width*@shape1.height
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Ну, во-первых, вовсе не обязательно объект с наибольшей площадью будет реально наибольшим "по габаритам" и наоборот
Во-вторых, есть же свойство area, которое при всем своем несовершенстве площадь значительно точнее считает
И, в-третьих, признайтесь честно - у вас, вероятно, в каждой группе есть один объект, ограничивающий группу и вам надо именно его перекрасить? Если так, то задача на порядок проще и тривиальнее, чем топиковая
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Вот типичный пример таких групп. В группе 2 или более объектов. В частном случае объекты одинакового размера, тогда перекрасить нижний.
1618227755336.png
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Ну так и перекрашивайте нижний, если рамка под всеми обьектами лежит. Это же проще и логичнее чем обьект с максимальной площадью зачем то искать
 

tohaa

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

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
больший может быть сверху.
Ок, но перекрывает он все объекты - гарантированно?
Тогда его габариты должны совпадать с габаритами всей группы - все равно ищется быстрее
 

tohaa

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

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Ну так и задавайте в поисковом запросе габариты всей группы
 

tohaa

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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
я налепил из нескольких найденных макросов что-то похожее, но заставить работать не получается.
Код:
Sub Testfind()
  Dim sr As ShapeRange
  Dim obj As ShapeRange
  Dim sr_counter2 As Long
 
 
  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)
 
  If sr.count <> 0 Then
 
Set obj = sr

obj.Ungroup

obj.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"

For sr_counter2 = obj.count To 2 Step 1

obj(sr_counter2 - 1).SetOutlineProperties color:=CreateCMYKColor(100, 0, 0, 0)

obj.Group

Next sr_counter2



  Else
    MsgBox "There are no group on the current page"
  End If
End Sub
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Какой то совершенно безумный индусский код
После obj.Ungroup все ваши группы непоправимо рассыпятся на отдельные шейпы, которые вы потом не соберете в исходный порядок никогда
Или я чего то не догоняю в вашей хотелке?
Вам же надо для каждой группы найти рамку, зачем вы разгруппировываете-группируете, это же деструктивная операция
Конструкция obj.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height" тоже внушает сомнения , у вас на ней макрос не ругается? В лучшем случае вся ваша куча разгруппированных шейпов будет переранжирована по произведению линейных размеров - это разве то что вам надо?
И, как вишенка на торте, вы зачем то в цикле одни и те же объекты перекрашиваете и группируете
Вангую что этот код обрушится на Sort но в этот момент макет уже будет уничтожен
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Какой то совершенно безумный индусский код
После obj.Ungroup все ваши группы непоправимо рассыпятся на отдельные шейпы, которые вы потом не соберете в исходный порядок никогда
Или я чего то не догоняю в вашей хотелке?
Вам же надо для каждой группы найти рамку, зачем вы разгруппировываете-группируете, это же деструктивная операция
Конструкция obj.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height" тоже внушает сомнения , у вас на ней макрос не ругается? В лучшем случае вся ваша куча разгруппированных шейпов будет переранжирована по произведению линейных размеров - это разве то что вам надо?
И, как вишенка на торте, вы зачем то в цикле одни и те же объекты перекрашиваете и группируете
Вангую что этот код обрушится на Sort но в этот момент макет уже будет уничтожен
Sort у меня работает нормально в другом макросе. Буду ковырять дальше по вашим комментариям.
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Sort у меня работает нормально в другом макросе.
В каком контексте оно работает?
И что и как вы собираетесь отсортировать в данном макросе?
У ShapeRange попросту нету метода Sort, да и вообще не понятно как бы он работал если б был
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
В каком контексте оно работает?
И что и как вы собираетесь отсортировать в данном макросе?
У ShapeRange попросту нету метода Sort, да и вообще не понятно как бы он работал если б был
Sub space_it_right_vert2()

Dim sr As ShapeRange
Dim sr_counter As Long

Const space_dist As Double = 0.19685
Set sr = ActiveSelectionRange
sr.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"

For sr_counter = sr.count To 2 Step -2
sr(sr_counter - 1).LeftX = sr(sr_counter).RightX + space_dist
sr(sr_counter - 1).TopY = sr(sr_counter).BottomY - space_dist
Next sr_counter



End Sub
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
А хотя вру, в более новых корелах ошибку уже не выдает
Но и не работает