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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
1618300935602.png
до запуска.
1618300967578.png
после запуска макроса
 

_MBK_

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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Sub testsize3()

Dim sr As ShapeRange

Dim sr_counter As Long

Set sr = ActiveSelectionRange

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


For sr_counter = sr.Count To 2 Step -1

sr(sr_counter - 1).LeftX = sr(sr_counter).RightX + 5

sr(sr_counter - 1).CenterY = sr(sr_counter).CenterY

Next sr_counter


End Sub
Я не понимаю как управлять цветом самого большого объекта. Подскажите(
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
В смысле? У вас же уже есть упорядоченный массив, вместо сдвижки сделайте
obj(obj.count).SetOutlineProperties color:=CreateCMYKColor(100, 0, 0, 0)
и самый последний перекрасится
 
  • Спасибо
Реакции: tohaa

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
В смысле? У вас же уже есть упорядоченный массив, вместо сдвижки сделайте
obj(obj.count).SetOutlineProperties color:=CreateCMYKColor(100, 0, 0, 0)
и самый последний перекрасится
Код:
Sub testsize3()

Dim sr As ShapeRange

Dim sr_counter As Long

Set sr = ActiveSelectionRange

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


For sr_counter = sr.Count To 2 Step -1


Next sr_counter

sr(sr.Count).SetOutlineProperties color:=CreateCMYKColor(100, 0, 0, 0)

End Sub

Если так, то не работает.
 

lev

Модератор
20 лет на форуме
Сообщения
2 142
Реакции
2 066
sr(sr.Count).Outline.SetProperties Color:=CreateCMYKColor(100, 0, 0, 0)
 
  • Спасибо
Реакции: tohaa

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Фантастика! Спасибо.
 

_MBK_

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

DukereD

макрософил
Сообщения
459
Реакции
111
Какой-то сложный на мой взгляд подход.
Простая рекурсия и пробегаем по всем объектам. самый большой объект запихиваем в переменную. потом после цикла переменную красим.
 

_MBK_

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

tohaa

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

Сейчас макрос находит все группы, сортирует и окрашивает самый большой объект во всех группах

Код:
Sub Testfind()

  Dim sr As ShapeRange
  Dim sr_counter As Long
 
  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)

 
  If sr.Count <> 0 Then
 
sr.Ungroup

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

sr(sr.Count).Outline.SetProperties color:=CreateCMYKColor(100, 0, 0, 0)


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

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Я ж вам сто раз говорил - разгруппировывать ничего не надо
Примерно как то так не знаю будет ваш Sort работать с Shapes адекватно пишу с утюга
Код:
Sub Testfind()

  Dim sr As ShapeRange
  Dim sr_counter As Long

  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)


  If sr.Count <> 0 Then

for each sp in sr
  sp.Shapes.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"

  sp.Shapes(sp.Shapes.Count).Outline.SetProperties color:=CreateCMYKColor(100, 0, 0, 0)
next sp


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

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
tck
Я ж вам сто раз говорил - разгруппировывать ничего не надо
Примерно как то так не знаю будет ваш Sort работать с Shapes адекватно пишу с утюга
Код:
Sub Testfind()

  Dim sr As ShapeRange
  Dim sr_counter As Long

  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)


  If sr.Count <> 0 Then

for each sp in sr
  sp.Shapes.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"

  sp.Shapes(sp.Shapes.Count).Outline.SetProperties color:=CreateCMYKColor(100, 0, 0, 0)
next sp


  Else
    MsgBox "There are no group on the current page"
  End If
End Sub
Этот код не работает. Вместо sr вы писали sp? или sp это отдельный shaperange?

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

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
Вместо sr вы писали sp? или sp это отдельный shaperange?
sr - это коллекция групп, которую вы получили после поиска
Я в цикле перебираю ее по очереди sp - текущий элемент данной коллекции т е группа с которой мы проводим действия
Что именно не работает?
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
sr - это коллекция групп, которую вы получили после поиска
Я в цикле перебираю ее по очереди sp - текущий элемент данной коллекции т е группа с которой мы проводим действия
Что именно не работает?
Код:
Sub Testfind()


  Dim sp As Shape
  Dim sr As ShapeRange
  Dim sr_counter As Long


  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)

  If sr.Count <> 0 Then

For Each sp In sr
 
  sp.Shapes.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"
  sp.Shapes(sp.Shapes.Count).Outline.SetProperties color:=CreateCMYKColor(100, 0, 0, 0)


Next sp


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

1618402949086.png
 

_MBK_

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


  Dim sp As Shape
  Dim sr As ShapeRange
  Dim sr_counter As Long


  Set sr = ActivePage.FindShapes(Type:=cdrGroupShape)

  If sr.Count <> 0 Then

For Each sp In sr

  sp.Shapes.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"
  sp.Shapes(sp.Shapes.Count).Outline.SetProperties color:=CreateCMYKColor(100, 0, 0, 0)


Next sp


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

Посмотреть вложение 142646
Ну это почти очевидно, что где то неправильно метод или свойство, строка то какая в макросе на которую ругается? Я делаю ставку на sp.Shapes.Sort :(
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Ну это почти очевидно, что где то неправильно метод или свойство, строка то какая в макросе на которую ругается? Я делаю ставку на sp.Shapes.Sort :(
Как посмотреть строку на которую ругается? для shapes sort не могу найти описания.
 

_MBK_

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