Elemente ausserhalb Kurve per VBA löschen

[Sfassbender]

Hallo zusammen,

ich habe auf einer Seite eine Menge kleiner Shapes. (lauter gleich große Ellipsen) Darüber lege ich eine geschlossene Kurve. Wie kann man das per VBA lösen, dass alle Elemente, die nicht innerhalb der selektierten Kontur liegen (wenn möglich auch die "angeschnittenen"), gelöscht werden?

Für Eure Hilfe wäre ich sehr dankbar, da ich im Moment noch alle Elemente von Hand löschen muss.

Liebe Grüsse,

Stefan

[norre]

Hallo,
eine Möglichkeit ohne VBA mit ein bisserl Arbeit.

Benütze deine geschlossene Kurve als Powerclip für deine Ellipsen. Anschließend musst du nur noch die angeschnittenen Ellipsen über "Powerclip bearbeiten" von Hand löschen.

Gruß
Norre

Ps.
etwas Netiquette:
Wenn man eine Lösung erhält sollte man zumindest dem Antworter ein Feedback geben  
https://forum.juergens-workshops.de/show...#pid162140

[koter]

Hallo Stefan,

...Wie kann man das per VBA lösen, dass alle Elemente, die nicht innerhalb der selektierten Kontur liegen (wenn möglich auch die "angeschnittenen"), gelöscht werden?...

z.B. indem Du alle Ellipsenmittelpunkte mit IsOnShape auf die Lage in der selektierten Kontur abklopfst, diese mit IntersectsWith auf Überschneidungen mit derselben prüfst, die entsprechenden Ellipsen einer Range zuordnest und diese löscht.

Gruß

Koter

[Sfassbender]

Hallo,

schon mal vielen Dank für die Antworten.

@norre
Manuell löse ich das ganze im Moment über die Formen - Schnittmenge. Ja, die angeschnittenen muss ich auch hier einzeln löschen.

@Koter
den Ansatz mit "isOnshape" habe ich gesucht. Leider funktioniert mein kleines Skript nur bei einer kleinen Musterdatei.

Code:

Sub Test1()
Dim spattern As Shape
Dim srhole As New ShapeRange
Dim x As Double, y As Double
Dim s As LongLong
'ActiveDocument.ReferencePoint = 9
Set spattern = ActivePage.Shapes(1)
spattern.ConvertToCurves
For s = ActivePage.Shapes.Count To 2 Step -1
ActivePage.Shapes(s).GetPosition x, y
    Select Case spattern.IsOnShape(x, y, 0.02)
        Case cdrOnMarginOfShape
        srhole.Add ActivePage.Shapes(s)
    End Select
        Select Case spattern.IsOnShape(x, y)
        Case cdrOutsideShape
        srhole.Add ActivePage.Shapes(s)
    End Select
Next
srhole.Delete
End Sub

Dabei ist die Kurve, ausserhalb der ich die anderen Elemente löschen will immer shape(1).


Teil 1 Case cdrOnMarginOfShape funktioniert eigentlich sehr gut.
Nur Case cdrOutsideShape bekomme ich nicht hin.

Ich hab ein bisschen mit ActiveDocument.ReferencePoint rumgespielt (da ich davon echt keine Ahnung hab) und erhalte unterschiedliche Ergebnisse. Leider nicht die richtigen. Hast du dazu einen Tipp für mich?

Liebe Grüsse,
Stefan

[koter]

Hallo Stefan,

ich dachte schon, Du liest die Antworten gar nicht.

den Ansatz mit "isOnshape" habe ich gesucht. Leider funktioniert mein kleines Skript nur bei einer kleinen Musterdatei.

Ich habe meine Antwort in ein Codebeispiel übersetzt, und als Kommentar eingefügt.
Vielleicht funktioniert das ja bei Deiner Datei. Die kenne ich nicht, also kann ich es nicht versprechen.

Code:

Sub Ellipsenkiller()
   Dim s As Shape, spattern As Shape
   Dim srhole As New ShapeRange
   Dim x As Integer
   Set spattern = ActivePage.Shapes(1)
   
   For Each s In ActivePage.Shapes.AllExcluding(Array(1))
       'indem Du alle Ellipsenmittelpunkte mit IsOnShape auf die Lage in der selektierten Kontur abklopfst:
       x = spattern.IsOnShape(s.CenterX, s.CenterY)
       If x > 0 Then
           'diese mit IntersectsWith auf Überschneidungen mit derselben prüfst:
           If s.DisplayCurve.IntersectsWith(spattern.DisplayCurve) Then
               srhole.Add s 'die entsprechenden Ellipsen einer Range zuordnest
           End If
       Else
           srhole.Add s 'die entsprechenden Ellipsen einer Range zuordnest
       End If
   Next
   srhole.Delete 'und diese löschst,
   
End Sub

...Ich hab ein bisschen mit ActiveDocument.ReferencePoint rumgespielt (da ich davon echt keine Ahnung hab) und erhalte unterschiedliche Ergebnisse. Leider nicht die richtigen. Hast du dazu einen Tipp für mich?

Der ReferencePoint entspricht dem Objektursprung, den Du ganz links auf der Eigenschaftsleiste findest.
Ich glaube nicht, das der uns bei Deiner Aufgabe helfen kann.

Gruß

Koter

[Sfassbender]

Hallo Stefan,

ich dachte schon, Du liest die Antworten gar nicht.

Guten Morgen,

doch, doch. Ich habs direkt gelesen. Ich bin nur kein Fan von Antworten wie "Danke, ich werds später mal versuchen."

Ich hab das am Freitag probiert und dann kam das heilige Wochenende dazwischen.

Danke aber nochmal für Deine Hilfe. Funktioniert super und schnell, mit einer Einschränkung.
Ich denke ich habe zu wenig Arbeitsspeicher für diese Aufgabe. Da es sehr viele Ellipsen sind, bekomme ich leider nicht das richtige Ergebnis. Reduziere ich die Anzahl der Ellipsen, funktionierts prima.

Ich glaube, ich werde das ganze mal andersherum probieren. Das ursprüngliche Shape mit den Ellipsen füllen....

Vielen Dank!

Stefan

[koter]

Hallo Stefan,

...und dann kam das heilige Wochenende dazwischen...

Ich meinte eigentlich diesen Beitrag,  aber das war ja auch vor 225 Wochenenden, ist also schon lange her!  

...Ich denke ich habe zu wenig Arbeitsspeicher für diese Aufgabe. Da es sehr viele Ellipsen sind, bekomme ich leider nicht das richtige Ergebnis. Reduziere ich die Anzahl der Ellipsen, funktionierts prima...

Mich würde sehr interessieren, unter welchen Umständen das Makro versagt!
Kannst Du das näher beschreiben oder vielleicht sogar die Datei anhängen? Das wäre super!

Ich habe es mit bis zu 40.000 Ellipsen getestet und nicht einmal hat das Makro versagt.
Hier ein Test mit 22.500 Ellipsen:



Der Rechner hat nur 4 GB Arbeitsspeicher, mit eingeschalteter Optimierung (Optimization = true) ging es aber doch recht flott.

Ich würde gerne wissen ob ich einen Denkfehler in das Makro gepackt habe oder sich ein anderer Grund findet, warum es bei Dir versagt hat.

Gruß

Koter

[Sfassbender]

Guten Morgen Koter,

an der Anzahl der Kurven liegt es offensichtlich nicht.
Wenn ich die Ellipsen neu erstelle, eine Kontur drüber zeichne und das Makro laufen lasse, funktioniert es.
Kopiere ich die Ellipsen aus einer anderen Datei und zeichen die Kontur (freihand) drüber, löscht er abwechselnd falsche Kurven. Hängt scheinbar auch davon ab, wohin ich die Kontur verschiebe.

Selbst wenn ich die Kontur aus einer anderen datei via copy paste über die erstellen Ellipsen einfüge gibts nur Gewurschtel.

Um das ganze noch verwirrender zu machen, hab ich Dir drei Bilder angehängt.
Bild 04 = Ausgangsposition
Bild 05 = Zoom mit F3 geändert - Makro laufen lassen
Bild 06 = Zoom mit F4 auf alle Elemente - Makro laufen lassen


Ich hatte gestern in einer andern Angelegenheit das Problem, das ein Makro, dass eine Range über die x- bzw. y-Koordinaten erstellt seltsame Ergebnisse lieferte. Hier hatte allerdings jemand den Ursprung des Lineals verstellt.

Jetzt frage ich mich, ob das in diesem Fall eine ähnliche Ursache haben könnte. Von wegen Ursprung der xy Koordinaten, Layer, ...

Hättest du dazu noch eine Idee?

[koter]

Hallo Stefan,

vielen Dank für die ausführliche Antwort und den Dateianhang!

beim Testen hatte ich die Kontur immer auf einer eigenen Ebene, deshalb wurde sie bei mir nicht gelöscht.
Ich habe das Makro so angepasst, dass die Kontur nicht mehr ausgewählt wird (wenn sie ganz oben liegt).

Die Genauigkeit von „IsOnShape“ hängt seltsamerweise vom Zoom ab. je höher der Zoom desto genauer arbeitet die Methode. Ich habe das Makro so angepasst, dass der Zoom hochgesetzt, die Methode ausgeführt und der Zoom dann zurückgesetzt wird. Wenn die Optimierung eingeschaltet ist, bekommt der User nichts davon mit.

Code:

Sub Ellipsenkiller()
   Dim S As Shape, spattern As Shape
   Dim srhole As New ShapeRange
   Dim x As Integer
   Dim z As Double, oX As Double, oY As Double, oW As Double, oH As Double
   On Error GoTo Ende
   Set spattern = ActivePage.Shapes(1)
   ActiveDocument.BeginCommandGroup "Ellipsenkiller"
   Application.Optimization = True
   Call ActiveWindow.ActiveView.GetViewArea(oX, oY, oW, oH)
   ActiveWindow.ActiveView.Zoom = 1600
   
   For Each S In ActiveLayer.Shapes.AllExcluding(1)
       x = spattern.IsOnShape(S.CenterX, S.CenterY)
       If x > 0 Then
           If S.DisplayCurve.IntersectsWith(spattern.DisplayCurve) Then
               srhole.Add S
           End If
       Else
           srhole.Add S
       End If
   Next
   
   srhole.Shapes.All.Delete
Ende:
   Call ActiveWindow.ActiveView.SetViewArea(oX, oY, oW, oH)
   Application.Optimization = False
   Application.Windows.Refresh
   ActiveDocument.EndCommandGroup
End Sub

Leider hat Corel die Methode in der Hilfe nicht ausreichend Dokumentiert. Da sie aber im Hilfe-Beispiel zusammen mit „GetUserClick“ verwendet wird, könnte das die Erklärung sein. Je höher der User den Zoom einstellt, desto genauer muss die Methode arbeiten.

Mann kann Natürlich auch andere Methoden verwenden, wenn man den Zoom nicht antasten will.

Beispiel:

Code:

Sub Ellipsenkiller2()
   Dim s1 As Shape
   On Error GoTo Ende
   ActiveDocument.BeginCommandGroup "Ellipsenkiller2"
   Application.Optimization = True
   
   Set s1 = ActiveLayer.Shapes.AllExcluding(1).Combine.Trim(ActiveLayer.Shapes(1), False, True)
   s1.Curve.SubPaths(1).Delete
   s1.BreakApart
   
Ende:
   Application.Optimization = False
   Application.Windows.Refresh
   ActiveDocument.EndCommandGroup
End Sub

Das Makro verwendet die  Methode „Trim“.
Man braucht weniger Codezeilen, es dauert aber länger und es können nur geschlossene Konturen verwendet werden.
Die Ellipsen werden in Kurven gewandelt. Wenn es Ellipsen bleiben müssen, kannst Du die Methode also nicht verwenden.

Ich weiß nicht, wo Du das Makro einbauen willst, und wozu es genau dient. Aber vielleicht findet sich ja eine Maßgeschneiderte Lösung für Deinen Zweck.

...Ich hatte gestern in einer andern Angelegenheit das Problem, das ein Makro, dass eine Range über die x- bzw. y-Koordinaten erstellt seltsame Ergebnisse lieferte. Hier hatte allerdings jemand den Ursprung des Lineals verstellt...
Jetzt frage ich mich, ob das in diesem Fall eine ähnliche Ursache haben könnte. Von wegen Ursprung der xy Koordinaten, Layer, ...
Hättest du dazu noch eine Idee?

Dass bei diesem Makro der Koordinatenursprung eine Rolle spielt, halte ich für unwahrscheinlich weil keine absoluten Koordinaten verwendet werden.
Wenn Du annimmst, dass ein Benutzer den Ursprung umstellt, kannst Du Deine Koordinaten ja auf einen Referenzpunkt (z.B den Seitenrand) beziehen, oder den Ursprung mit „DrawingOriginX“ und „DrawingOriginY“ zurücksetzen.

Nachtrag:
Den Ursprung sollte man nach der Bearbeitung wieder auf die Werte des Benutzers zurückstellen. Der Benutzer wird (wahrscheinlich) einen Grund für sein Handeln gehabt haben.
Außerdem wäre es unhöflich Benutzereinstellungen ungefragt zu ändern.

Gruß

Koter

[Sfassbender]

Hallo Koter,

vielen, vielen Dank! Genau das was ich brauche. Funktioniert einwandfrei und da mir der Zoom gleichgültig ist, läuft Dein erster Code auch angenehm schnell. (Das ist natürlich relativ bei ca. 100.000 Ellipsen)

Diese Teile werden die Vorlage für perforierte Textilien. Die Ellipsen sollen die Bohrlöcher im Stoff darstellen. Auf diese Weise kann ich auch evtl. Schriften oder Muster innerhalb der Kontur erstellen.

Ich habe da zwar noch ein Problem mit der "nachgeordneten" Stelle. Dabei gebe ich die cdr als dxf aus. Es gibt wohl scheinbar noch das Problem, die kleinen Ellipsen oder Kurven beim Import in Autocad als Kreise darzustellen.
Da ich weder Autocad anwende noch kenne, kann ich dazu auch noch nix sagen.

Also dann nochmal vielen Dank!

Stefan