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

tohaa

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

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

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

_MBK_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776

tohaa

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

_MBK_

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

tohaa

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

_MBK_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776
Ну так и перекрашивайте нижний, если рамка под всеми обьектами лежит. Это же проще и логичнее чем обьект с максимальной площадью зачем то искать
 

tohaa

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

_MBK_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776
больший может быть сверху.
Ок, но перекрывает он все объекты - гарантированно?
Тогда его габариты должны совпадать с габаритами всей группы - все равно ищется быстрее
 

tohaa

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

_MBK_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776
Ну так и задавайте в поисковом запросе габариты всей группы
 

tohaa

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

tohaa

Участник
Топикстартер
Сообщения
117
Реакции
3
я налепил из нескольких найденных макросов что-то похожее, но заставить работать не получается.
Код:
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_

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

tohaa

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

_MBK_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776
Sort у меня работает нормально в другом макросе.
В каком контексте оно работает?
И что и как вы собираетесь отсортировать в данном макросе?
У ShapeRange попросту нету метода Sort, да и вообще не понятно как бы он работал если б был
 

tohaa

Участник
Топикстартер
Сообщения
117
Реакции
3
В каком контексте оно работает?
И что и как вы собираетесь отсортировать в данном макросе?
У 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_

Пикирующий бомбардировщик
12 лет на форуме
Сообщения
29 707
Реакции
9 776
А хотя вру, в более новых корелах ошибку уже не выдает
Но и не работает