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

  • Автор темы Автор темы tohaa
  • Дата начала Дата начала
1618300935602.png
до запуска.
1618300967578.png
после запуска макроса
 
tohaa сказал(а):
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
Нажмите, чтобы раскрыть...
Я не понимаю как управлять цветом самого большого объекта. Подскажите(
 
В смысле? У вас же уже есть упорядоченный массив, вместо сдвижки сделайте
obj(obj.count).SetOutlineProperties color:=CreateCMYKColor(100, 0, 0, 0)
и самый последний перекрасится
 
  • Спасибо
Реакции: tohaa
_MBK_ сказал(а):
В смысле? У вас же уже есть упорядоченный массив, вместо сдвижки сделайте
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

Если так, то не работает.
 
sr(sr.Count).Outline.SetProperties Color:=CreateCMYKColor(100, 0, 0, 0)
 
  • Спасибо
Реакции: tohaa
Фантастика! Спасибо.
 
Какой-то сложный на мой взгляд подход.
Простая рекурсия и пробегаем по всем объектам. самый большой объект запихиваем в переменную. потом после цикла переменную красим.
 
DukereD сказал(а):
Какой-то сложный на мой взгляд подход.
Нажмите, чтобы раскрыть...
Наоборот упрощенный
Как я понимаю, группы там простые и не рекурсивные, достаточно просто Shapes перебирать у каждой группы
Более того, я с самого начала говорил что и перебор с сортировкой не нужен, достаточно найти один объект с габаритами группы
Но раз сортировка заработала то можно и так
 
Помогите понять как правильно написать:
поиск групп в документе
разгруппировку и сортировку содержимого группы по размеру.
перекрашивание и группировку снова.

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

Код: 
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
 
Я ж вам сто раз говорил - разгруппировывать ничего не надо
Примерно как то так не знаю будет ваш 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
 
tck
_MBK_ сказал(а):
Я ж вам сто раз говорил - разгруппировывать ничего не надо
Примерно как то так не знаю будет ваш 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?

Если не разгруппировывать, то окрашивается целиком группа, содержащая больший объект.
 
tohaa сказал(а):
Вместо sr вы писали sp? или sp это отдельный shaperange?
Нажмите, чтобы раскрыть...
sr - это коллекция групп, которую вы получили после поиска
Я в цикле перебираю ее по очереди sp - текущий элемент данной коллекции т е группа с которой мы проводим действия
Что именно не работает?
 
_MBK_ сказал(а):
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
 
tohaa сказал(а):
Код: 
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 :(
 
_MBK_ сказал(а):
Ну это почти очевидно, что где то неправильно метод или свойство, строка то какая в макросе на которую ругается? Я делаю ставку на sp.Shapes.Sort :(
Нажмите, чтобы раскрыть...
Как посмотреть строку на которую ругается? для shapes sort не могу найти описания.
 
Для ответа нужно войти/зарегистрироваться
Верх Низ