Найти и выделить незамкнутые кривые

divingdog / 13.07.2010, 15:19/00:41

Форум:

Банально взять и выделить все незамкнутые кривые. Средствами корела сделать не удалось, а требуеться постоянно. Буду очень признателен.

divingdog / 14.07.2010, 04:51

Да в общем уже и не нужен ,я сохранил пресет поиска и всё стало не особо запарно.

Добавлено (14.07.2010, 01:51)
---------------------------------------------
Вот вроде уже всё и получилось и хоп опять беда. Проверял я эту фигню так накидал кругов с квадратами и фрихендом начиркал линий. Всё отлично работает. Но вот все эти круги с квадратами грохнуть в кривые и поиск находит и их тоже хотя они вполне закрыты. А wOxxOm скрипт я так и не нашел.

Файлы

find_open_patch_8311508.rar

Des425 / 14.07.2010, 14:35

Держи макросы, здесь приличная коллекция и много полезного, так что установишь, потом среди них поищи!

Автор wOxxOm

Файлы

zzOsman_5173470.rar

divingdog / 14.07.2010, 15:00

Во! Есть! То что надо! СУПЕР! От спасибо!

GoodvinVV / 04.10.2010, 16:11/16:13

Private Sub CommandButton1_Click() 'найти все не замкнутые

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

ActiveWindow.ActiveView.ToFitSelection

End Sub

Private Sub CloseCurves_Click() 'закрыть все не замкнутые

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 sh.Curve.Closed = True 'sh.CreateSelection

'OrigSelection(1).Curve.Closed = True
Next sh

ActiveWindow.ActiveView.ToFitSelection

End Sub

Private Sub CommandButton2_Click() 'замкнуть все не замкнутые по одной

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 sh.CreateSelection

Next sh

Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
OrigSelection(1).Curve.Closed = True

End Sub

kuman / 05.10.2010, 12:57

А можно тоже самое для нахождения линз?

Sancho / 05.10.2010, 13:05/16:14

Вот для всего

GoodvinVV, у нас на сайте есть тег CODE!!! Сообщение отредактировал.

GoodvinVV / 07.10.2010, 14:34

Можно и про линзы....

Добавлено (07.10.2010, 11:30)
---------------------------------------------
Private Sub ComButton_Click()

Dim s As Shape, eff As Effect
  For Each s In ActivePage.Shapes
   For Each eff In s.Effects
    If eff.Type = cdrLens Then

     Select Case eff.Lens.Type
      Case cdrLensBrighten, cdrLensColorAdd, cdrLensColorLimit, cdrLensCustomColorMap, cdrLensFishEye, cdrLensHeatMap, cdrLensInvert, cdrLensMagnify, cdrLensTintedGrayscale, cdrLensTransparency, cdrLensWireframe
      s.CreateSelection
          MsgBox " Lens Effects!!!"

      End Select
     Exit For
    End If
   Next eff
  Next s
End Sub

Добавлено (07.10.2010, 11:34)
---------------------------------------------
только не везде ищет!!! поверклипы и группы помойму пропускает поэтому только суть...
Select Case eff.Lens.Type Case cdrLensBrighten, cdrLensColorAdd................. а где искать укажи, где тебе нужно сам. :)

kuman / 07.10.2010, 15:12

Ага, спасибо
Нашел как сделать по другому, меньше кода :D
Private Sub CommandButton1_Click()

Dim s As Shape
     For Each s In ActivePage.Shapes
     If Not s.Effects.LensEffect Is Nothing Then
     s.ConvertToBitmapEx cdrCMYKColorImage, False, True, 300, cdrNormalAntiAliasing, True, False, 95
     End If
Next s

End Sub

Но тоже проблема,

не везде ищет!!! поверклипы и группы пропускает

Так что будем думать дальше

GoodvinVV / 07.10.2010, 16:57

Так что будем думать дальше

однажды wOxxOm поделился со мной кодом: отлично ищет по всем шапам практически...

Добавлено (07.10.2010, 13:57)
---------------------------------------------
http://powerclip.ru/modules/newbb/viewtopic.php?topic_id=9249&forum=19

Найти и выделить незамкнутые кривые

Страницы