|
wyszukanie krzywej o określonej ilości węzłów i podścieżek |
| Autor |
Wiadomość |
michal.s 
Praktyk
Wersja CorelDRAW: x4
Pomógł: 1 raz
Dołączył: 01 Lut 2012
Posty: 66
Skąd: Poznań
|
 Wysłany: 15 Wrzesień 2014, 12:18 wyszukanie krzywej o określonej ilości węzłów i podścieżek
|
|
|
Witam Wszystkich.
Czy jest może opcja, żeby za pomocą makra wyszukać krzywą która ma 4 węzły i dwie podścieżki.
Chodzi mi o wyszukanie w pracy krzyżyków (4 węzły, 2 podścieżki) z pominięciem kwadratów (4 węzły, 1 podścieżka).
W Corelu jest opcja wyszykiwania np krzywej i można tam zadać parametr żeby wyszukać węzły (niestety tylko węzły) o dokładnej ilości, mniejszej i większej.
Na pewno można to przygotować...  |
|
 |
|
 |
maroQ
Doradca
Pomógł: 16 razy
Wiek: 40
Dołączył: 08 Lut 2011
Posty: 117
Skąd: Kalisz
|
| Wysłany: 15 Wrzesień 2014, 15:02
|
|
|
| michal.s napisał/a: | | 4 węzły i dwie podścieżki |
Jak dla mnie to 2 podścieżki po dwa węzły każda.
To będzie coś w tym stylu:
| Kod: | Sub FindCross()
Dim s As Shape
For Each s In ActivePage.Shapes.FindShapes(Type:=cdrCurveShape)
If s.Curve.SubPaths.Count = 2 Then
If s.Curve.SubPaths(1).Nodes.Count = 2 And s.Curve.SubPaths(2).Nodes.Count = 2 Then
ActiveWindow.ActiveView.SetViewPoint s.LeftX + (s.SizeWidth) / 2, s.BottomY + (s.SizeHeight) / 2, 200
If MsgBox("Czy to ten?", vbYesNo, "Pytanie?") = vbYes Then
Exit Sub
End If
End If
End If
Next s
End Sub |
Nie pamiętam jak się skalowało podgląd by obejmował całe okno, ale jakby to było bardzo potrzebne to poszukam w starym kodzie. Tak przy okazji zapytam: Po co Ci te krzyżyki? Czy pracujesz może na mapach geodezyjnych? Bo tam takowe krzyżyki się pojawiają regularnie. Tam krzyżyki posiadają podścieżki w postaci odcinków przecinających się pod kątem prostym i to też można by w tym przypadku sprawdzać. |
|
 |
|
|
michal.s
Praktyk
Wersja CorelDRAW: x4
Pomógł: 1 raz
Dołączył: 01 Lut 2012
Posty: 66
Skąd: Poznań
|
| Wysłany: 15 Wrzesień 2014, 17:27
|
|
|
Fajnie to działa i znajduje problematyczne krzyżyki
Gdyby jeszcze po wskazaniu odpowiedniego elementu (Czy to ten?) zaznaczyło wszystkie identyczne... to nie mógłbym napisać "nie lubię poniedziałku" 
Nawiązując do skalowania to:
| Cytat: | | Nie pamiętam jak się skalowało podgląd by obejmował całe okno... |
ActiveWindow.ActiveView.ToFitSelection
| Cytat: | | Po co Ci te krzyżyki? |
Krzyżyki są automatycznie przydzielane do poszczególnych elementów na pracy.
Potrzebne one są do precyzyjnego zmontowania poszczególnych elementów na folii (w załaczeniu plik)
W takiej wersji (bez warstw) importuję eps-a do Corela i zależy mi na wyodrębnieniu na inną warstwę krzyży oraz oznaczeń przy nich umieszczonych. |
|
|
|
|
|
maroQ
Doradca
Pomógł: 16 razy
Wiek: 40
Dołączył: 08 Lut 2011
Posty: 117
Skąd: Kalisz
|
| Wysłany: 17 Wrzesień 2014, 15:51
|
|
|
| michal.s napisał/a: | | ActiveWindow.ActiveView.ToFitSelection |
Mi chodziło o "ActiveWindow.ActiveView.ToFitShape" ale itak dzięki.
To będzie coś w tym rodzaju:
| Kod: | Sub FindSimularCross()
If ActiveSelectionRange.Count = 0 Then GoTo bang
Dim s As Shape, sa As Shape
Dim sr As New ShapeRange
Set sa = ActiveShape
If sa.Type <> cdrCurveShape Then GoTo bang
If sa.Curve.SubPaths.Count <> 2 Then GoTo bang
ActiveDocument.Unit = cdrMillimeter
For Each s In ActivePage.Shapes.FindShapes(Type:=cdrCurveShape)
If s.Curve.SubPaths.Count = 2 Then
If s.Curve.SubPaths(1).Nodes.Count = 2 And s.Curve.SubPaths(2).Nodes.Count = 2 Then
If Math.Abs(s.Curve.SubPaths(2).Nodes.First.PositionX - s.Curve.SubPaths(1).Nodes.First.PositionX) = Math.Abs(sa.Curve.SubPaths(2).Nodes.First.PositionX - sa.Curve.SubPaths(1).Nodes.First.PositionX) _
And Math.Abs(s.Curve.SubPaths(2).Nodes.First.PositionY - s.Curve.SubPaths(1).Nodes.First.PositionY) = Math.Abs(sa.Curve.SubPaths(2).Nodes.First.PositionY - sa.Curve.SubPaths(1).Nodes.First.PositionY) _
Then
sr.Add s
End If
End If
End If
Next s
ActiveSelectionRange.RemoveFromSelection
ActiveWindow.ActiveView.ToFitShapeRange sr
sr.CreateSelection
MsgBox "Znaleziono: " & sr.Count & " krzyżyków", vbInformation, "OK"
Exit Sub
bang:
MsgBox "Nie zaznaczono właściwego kształtu!", vbExclamation, "Niet"
End Sub
|
|
|
|
|
|
|
michal.s
Praktyk
Wersja CorelDRAW: x4
Pomógł: 1 raz
Dołączył: 01 Lut 2012
Posty: 66
Skąd: Poznań
|
| Wysłany: 17 Wrzesień 2014, 23:28
|
|
|
WIELKIE DZIĘKI
a to w ramach podziękowania:-)
najlepiej obejrzeć kilka razy
http://youtu.be/Jbi2S8BZPws |
|
|
|
|
|
michal.s
Praktyk
Wersja CorelDRAW: x4
Pomógł: 1 raz
Dołączył: 01 Lut 2012
Posty: 66
Skąd: Poznań
|
| Wysłany: 27 Wrzesień 2014, 22:25
|
|
|
Działałem z makrem które napisałeś maroQ ale chyba coś źle robię ponieważ po zaznaczeniu krzyżyka znajduje mi tylko zaznaczony krzyżyk, innym razem zaznacza mi tylko dwa krzyże. Nie wiem co zrobić żeby zaznaczyło wszystkie zaznaczone elementy.
Jak zastosować Twoje makro żeby zaznaczyć wszystkie krzywe o czterech węzłach i dwóch podścieżkach?
Jaki będzie kod do zaznaczenia krzywej o określonej ilości węzłów np. 15 |
|
|
|
|
|
maroQ
Doradca
Pomógł: 16 razy
Wiek: 40
Dołączył: 08 Lut 2011
Posty: 117
Skąd: Kalisz
|
| Wysłany: 6 Październik 2014, 16:38
|
|
|
| michal.s napisał/a: | | znajduje mi tylko zaznaczony krzyżyk, innym razem zaznacza mi tylko dwa krzyże |
Znajduje tylko identyczne krzyże.
| michal.s napisał/a: | | Jak zastosować Twoje makro żeby zaznaczyć wszystkie krzywe o czterech węzłach i dwóch podścieżkach? |
Tu masz najprostszy możliwy kod:
| Kod: | Sub Find4Nodes2SubPaths()
Dim s As Shape
Dim sr As New ShapeRange
For Each s In ActivePage.Shapes.FindShapes(, cdrCurveShape)
If s.Curve.Nodes.Count = 4 And s.Curve.Segments.Count = 2 Then
sr.Add s
End If
Next s
ActiveSelectionRange.RemoveFromSelection
ActiveWindow.ActiveView.ToFitShapeRange sr
sr.CreateSelection
MsgBox "Znaleziono: " & sr.Count & " krzywych o 4 węzłach i 2 podścieżkach", vbInformation, "OK"
End Sub |
Jak chcesz sprawdzać jeszcze długości segmentów to w poprzednio publikowanym makrze zamień cały warunek zawierający instrukcje Abs na: | Kod: | If Math.Round(s.Curve.Length) = Math.Round(sa.Curve.Length) Then
sr.Add s
End If |
|
|
|
|
|
|
|
|
FAQ
Szukaj
Użytkownicy
Grupy
Rejestracja
Zaloguj
Download
