[CDR 2017-2021] Поиск незамкнутых кривых в CD 2017

  • Автор темы Автор темы shakhtar
  • Дата начала Дата начала
shakhtar сказал(а):
объединить эти два сборника
Нажмите, чтобы раскрыть...
так wx_Tools уже отредактирован - если прочтете описание его и zzOsmana - то увидите немало совпадений
- надо будет просто его дополнить тем, что wOxxOm видимо решил выбросить
там, сказать прямо, и без этого порядочно навалено всякого ... ну пусть ещё будет маленькая кучка

вижу-вижу ... уже выложили
вечером займусь ... хотя может вы с @_MBK_ ещё код поправите?
 
там всего-то
Код: 
Sub selectOpenCurves() ' =================================================================================================
   Dim sh As Shape, sr As New ShapeRange
   boostStart
   For Each sh In ActivePage.shapes
      If sh.Type = cdrCurveShape Then If Not sh.Curve.Closed Then sr.Add sh
   Next sh
   ActiveDocument.ClearSelection: ActiveDocument.AddToSelection sr
   boostFinish
End Sub

а у вас разговор за группы пошёл ...?
 
dastin сказал(а):
там всего-то
Код: 
Sub selectOpenCurves() ' =================================================================================================
   Dim sh As Shape, sr As New ShapeRange
   boostStart
   For Each sh In ActivePage.shapes
      If sh.Type = cdrCurveShape Then If Not sh.Curve.Closed Then sr.Add sh
   Next sh
   ActiveDocument.ClearSelection: ActiveDocument.AddToSelection sr
   boostFinish
End Sub

а у вас разговор за группы пошёл ...?
Нажмите, чтобы раскрыть...
Не работает : ошибку VBA выдает
 
Без обработки вложенных групп как то так
Код: 
Sub SelectUnclosedInGroup()
 Dim shRange As ShapeRange
 Dim sh As Shape
 
 Set shRange = ActiveSelectionRange
 If shRange.Count = 0 Or shRange(1).Type <> cdrGroupShape Then
    MsgBox "There is no selected groups in the current document!"
    Exit Sub
 End If
 shRange(1).RemoveFromSelection
 For Each sh In shRange(1).Shapes
  If sh.Type = cdrCurveShape Then
    
  If Not sh.DisplayCurve.Closed Then
    sh.AddToSelection
  End If
  End If
 Next sh


End Sub
А с вложенными не факт что можно вообще
 
  • Спасибо
Реакции: shakhtar
_MBK_ сказал(а):
Без обработки вложенных групп как то так
Код: 
Sub SelectUnclosedInGroup()
 Dim shRange As ShapeRange
 Dim sh As Shape
 
 Set shRange = ActiveSelectionRange
 If shRange.Count = 0 Or shRange(1).Type <> cdrGroupShape Then
    MsgBox "There is no selected groups in the current document!"
    Exit Sub
 End If
 shRange(1).RemoveFromSelection
 For Each sh In shRange(1).Shapes
  If sh.Type = cdrCurveShape Then
   
  If Not sh.DisplayCurve.Closed Then
    sh.AddToSelection
  End If
  End If
 Next sh


End Sub
А с вложенными не факт что можно вообще
Нажмите, чтобы раскрыть...
Работает. Но к сожалению без вложенных групп толку от него мало.
Но все равно респект. 'cooll)'
В старой версии вроде он опазнавал вложенные.
 
можно выделить все-все-все незамкнутые, но ...
перед этим надо или все группы разгруппировать или эти незамкнутые из этих групп "выдрать" ...
что будет для вас лучше?
 
Проверил сам - да, как и предполагал Кэп, работает только с разгруппированными
 
А вот так и с вложенными работает
Код: 
Sub ProcessShape(sr As ShapeRange, sh As Shapes)
   For Each shr In sh
      If shr.Type = cdrCurveShape Then
       If Not shr.Curve.Closed Then sr.Add shr
      Else
       If shr.Type = cdrGroupShape Then ProcessShape sr, shr.Shapes
      End If
      
   Next shr
End Sub

Sub selectOpenCurves() ' =================================================================================================
   Dim sh As Shape, sr As New ShapeRange
   ProcessShape sr, ActivePage.Shapes
  
   ActiveDocument.ClearSelection: ActiveDocument.AddToSelection sr
 
End Sub
 
  • Спасибо
Реакции: dastin и shakhtar
_MBK_ сказал(а):
А вот так и с вложенными работает
Код: 
Sub ProcessShape(sr As ShapeRange, sh As Shapes)
   For Each shr In sh
      If shr.Type = cdrCurveShape Then
       If Not shr.Curve.Closed Then sr.Add shr
      Else
       If shr.Type = cdrGroupShape Then ProcessShape sr, shr.Shapes
      End If
   
   Next shr
End Sub

Sub selectOpenCurves() ' =================================================================================================
   Dim sh As Shape, sr As New ShapeRange
   ProcessShape sr, ActivePage.Shapes
 
   ActiveDocument.ClearSelection: ActiveDocument.AddToSelection sr
 
End Sub
Нажмите, чтобы раскрыть...
'alil''cooll)'
PS кстати в 12й версии ,старый макрос с вложенными работает.
 
Последнее редактирование:
shakhtar сказал(а):
кстати в 12й версии ,старый макрос с вложенными работает
Нажмите, чтобы раскрыть...
давайте проверим ...
кривую незамкнутую и замкнутую сгруппируйте, скопируйте и снова сгруппируйте - будет 4 объекта, из них 2 незамкнутых
запомните что вы вызываете из 12 Корела - название макроса и пункт в нём
 
dastin сказал(а):
давайте проверим ...
кривую незамкнутую и замкнутую сгруппируйте, скопируйте и снова сгруппируйте - будет 4 объекта, из них 2 незамкнутых
запомните что вы вызываете из 12 Корела - название макроса и пункт в нём
Нажмите, чтобы раскрыть...
Ну что, я не знаю как проверять ,что ли ? Многоуровневую группировку делал - все работает.
Вот ,если ничего не напутал ,код :
Sub selectOpenCurves()
Dim sh As Shape, sr As New ShapeRange
boostStart
For Each sh In ActivePage.FindShapes(, cdrCurveShape)
If sh.Type = cdrCurveShape Then If Not sh.Curve.Closed Then sr.Add sh
Next sh
ActiveDocument.ClearSelection: sr.CreateSelection
boostFinish
End Sub
 
А! Ну такой код и у меня выделяет вложенные, он даже проще, чем мой
Вся фишка в том что FindShapes пофиг на группы оказывается можно их не перебирать
Видимо в сообщении #23 неверно скопировался 'hmmm'
 
dastin сказал(а):
ни-ни ... zz.rar\zzOsman2.gms /// другой, который не 2, я ещё не смотрел ...
да-а ... там похоже винегрет с оливье под шубой :)
Нажмите, чтобы раскрыть...
Ну лично у меня вот такой код
Код: 
Sub selectOpenCurves()
Dim sh As Shape, sr As New ShapeRange

For Each sh In ActivePage.FindShapes(, cdrCurveShape)
If sh.Type = cdrCurveShape Then If Not sh.Curve.Closed Then sr.Add sh
Next sh
ActiveDocument.ClearSelection: sr.CreateSelection

End Sub
выделяет все, включая вложенные
 
уф ... собрал из двух османов одного ... кое-что придется предать забвению
типа
загрузить цветовой профиль "Silko"
загрузить цветовой профиль "Swop2"
загрузить палитру "Summer" по пути C:\Programm Files\CorelDRAW 12 ////
CurveChannelMixer молодой как Буратино - без движков и красоты - простое окно c textbox-ами
TransformEach - упоминание есть ... а всё остальное пошло за молоком
TougleView
...
все равно остается МНОГА!
пихать всё это в wx_Tools /// ой, не знаю ... монстра получится ... хоть там пересечений немало
- и надо ещё декларации сравнить на предмет переменных
 
Для ответа нужно войти/зарегистрироваться
Верх Низ