Makro-Nachhilfe für Funktionen für alle Objekte

[asterix]

Hi Koter,

ich habe den Wert auf 0.01 gesetzt (0.1 ändert schon zu stark).

Code:

Sub KnotenRed()
   
   For Each s In ActiveSelection.Shapes
       s.Curve.Nodes.All.AutoReduce 0.01
   Next
End Sub

Aber das AutoReduce ändert nicht die Knotentypen, das "Knoten reduzieren" von CorelDraw aber schon.

[asterix]

Ich habe noch nicht viel Zeit zum Testen gehabt, aber eigentlich ist die Smoothing-Makro auch schon sehr gut alleine geeignet (z.B. mit 10 oder 20 oder 50 per Klick). Denn das reduziert ja auch die Knoten und wandelt sie auch direkt um in (teilweise) glatte Knoten. Ich frage mich daher, ob ich überhaupt beide brauche - wahrscheinlich kommt aber irgendwann der Anwendungsfall, wo dies so sein wird . Bevor ich das Smoothing-Makro kannte, war mir immer "Knoten reduzieren" lieber, weil das die Form besser erhält, aber dies geht nun auch mit niedrigen Smoothing-Raten ganz gut.

Von daher hat sich - eigentlich - meine Frage nach dem Makro für Knoten-Typ-Änderung (in glatt/symmetrisch) auch schon erledigt. Denn auch in 0.01 Einstellung reduziert das Makro viel zu stark und auch anders als die Schaltfläche "Knoten reduzieren".

Meinen Fehler in dem doppelten Einfügen (Code oben) würde ich aber gerne noch erkennen .

[asterix]

Hier nochmal mein leider schlechter Versuch eines Makros .

Ich habe aufgenommen, wie ein *.ai geöffnet wird, möchte da einige Änderungen vornehmen und es dann ins aktuelle Dokument (egal welches) einfügen. Es klappt schon fast vollständig.

(Also das mit dem doppelten Einfügen hat sich immerhin erledigt, ich habe einmal die Datei mit Pfad im Code entfernt. So geht es nun.)


Aber die hier neu gelernten Zeilen kann ich natürlich nicht immer einfach so einfügen . Es gibt einen Fehler "Typ nicht korrekt" bei dem Smoothing. Das RGB-Färben und Kontur auf 0 geht aber.

Bleiben am Ende des Tages also doch wieder nur zwei Fragen:
- wie kann ich das mit dem Smoothing hier im Code korrigieren?
- steht hinter der Schaltfläche "Knoten reduzieren" nur Autoreduce oder mehr?

Code:

Sub opencopy()
    ' Recorded 30.06.2024
    Dim lr1 As Layer
    Set lr1 = ActiveDocument.Pages(1).CreateLayer("Ebene 1")
    ' Recording of this command is not supported
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    impopt.MaintainLayers = True
    
    Dim s1 As Shape
    Set s1 = ActiveShape
    Dim grp1 As ShapeRange
    Set grp1 = ActiveSelection.UngroupEx
    Dim openopt As StructOpenOptions
    Set openopt = CreateStructOpenOptions
    With openopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim doc1 As Document
    Set doc1 = OpenDocumentEx("C:\objekt.ai", openopt)


        ActivePage.SelectableShapes.All.CreateSelection
    For Each s In ActiveSelection.Shapes: s.Curve.Nodes.All.Smoothen 20: Next
       ActiveSelection.Outline.SetProperties Color:=CreateRGBColor(0, 0, 0)
ActiveSelection.Outline.SetProperties Width:=0


    grp1.Copy
    doc1.Close
    Dim pasteopt As StructPasteOptions
    Set pasteopt = CreateStructPasteOptions
    With pasteopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveDocument.Pages(1).Layers("Ebene 1").PasteEx(pasteopt)
End Sub

(ich habe die neu eingefügten Zeilen hier nochmal etwas abgesetzt / hervorgehoben, einfärben geht im Code hier nicht)

[koter]

Hallo Asterix,

...
- wie kann ich das mit dem Smoothing hier im Code korrigieren?
...

Das in Betrag 4 gesagte gilt auch hier.
Du kannst also die Auswahl auf Objekte mit dem korrekten Typ reduzieren
oder eine Prüfung auf den korrekten Typ in die Schleife einbauen.

...
- steht hinter der Schaltfläche "Knoten reduzieren" nur Autoreduce oder mehr?
...

Da musst Du den zuständigen Programmierer bei Corel fragen.
(Falls Der tatsächlich antwortet, bitte unbedingt hier im Forum veröffentlichen  )
Ich vermute, dass nicht mehr aber etwas anderes dahinter steckt.
Es gibt noch die undokumentierte Methode AutoReduceNodes des Curve-Objekts.
Die kannst Du ja mal testen.

Gruß

Koter

[asterix]

vielen Dank nochmals!
So klappt es nun (nur der relevante Absatz mit meinen Einfügungen hier)

Code:

ActivePage.SelectableShapes.All.CreateSelection
      ActiveSelection.Outline.SetProperties Color:=CreateRGBColor(0, 0, 0)
      ActiveSelection.Outline.SetProperties Width:=0
      ActiveSelection.Fill.ApplyUniformFill CreateRGBColor(0, 0, 0)
      For Each sl In ActiveSelection.Shapes: sl.Curve.Nodes.All.Smoothen 20
      Next

Wie erwähnt ist so ein Smoothen 20 eigentlich schon sehr gut. Und es unterscheidet sich auch hier von dem von CorelDraw in der Symbolleiste angebotenen "Kurvenglättung", wenn man 20 auswählt. Das im Makro gefällt mir derzeit besser.

Das mit dem AutoReduceNode habe ich versucht, hat aber kein Ergebnis gebracht (nicht funktioniert). Im Internet fand ich dazu auch nichts.

Hätte ich noch etwas beim Code hier anders machen sollen?
Zu PrecisionMargin fand ich auch keine Informationen und dachte, es wäre so korrekt .

Code:

Sub KnotenRed()
       For Each s In ActiveSelection.Shapes
       s.Curve.Nodes.All.AutoReduce 0.01
   Next
End Sub

[asterix]

Hallo Koter,

ok hab doch noch eine Abschlussrunde an Fragen.
Wie kann ich den folgenden Code ändern, damit er bei Kurven und auch bei Objekten geht (gefüllte Fläche, aber keine Rechtecke, sondern nur eben ehemalige Kurven, die ich zu Objekten konvertiert habe)? Wenn ich das Makro zum Smoothen einzeln ausführe, wie hier im Thread besprochen, dann geht es, aber im Gesamt-Makro nicht. Ich habe es mal hinbekommen zwischendurch, aber jetzt nicht mehr.

Code:

For Each sl In ActiveSelection.Shapes: sl.Curve.Nodes.All.Smoothen 20
Next

Und: wie kann ich in CorelDraw VBA die Windows-Zwischenablage leeren? Solange ich nichts drin habe (oder manuell in Windows lösche), ist mein Illustrator-Datei-Einfügen ok, aber wenn etwas drin ist, kopier er natürlich auch die Zwischenablage noch zusätzlich rein.

Da ich eher zu Smoothen tendiere, dürfte sich dann meine andere "letzte" Frage zum AutoReduce erledigt haben. Wie du auch schreibst, wird CorelDraw da noch etwas anderes machen, weil AutoReduce irgendwie deutlich weniger leicht zu nutzen ist als Smoothen, von den Ergebnissen her.

---
und hier der Vollständigkeit halber der Gesamtcode, es funktioniert alles bis auf die beiden Sachen, die ich gerade genannt habe.

Code:

Sub opencopy()
    ' Recorded 30.06.2024
    Dim lr1 As Layer
    Set lr1 = ActiveDocument.Pages(1).CreateLayer("Ebene 1")
    ' Recording of this command is not supported
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    impopt.MaintainLayers = True
    Dim impflt As ImportFilter
    Set impflt = lr1.ImportEx("C:\objekt.ai", 1283, impopt)
    impflt.Finish
    Dim s1 As Shape
    Set s1 = ActiveShape
    Dim grp1 As ShapeRange
    Set grp1 = ActiveSelection.UngroupEx
    Dim openopt As StructOpenOptions
    Set openopt = CreateStructOpenOptions
    With openopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim doc1 As Document
    Set doc1 = OpenDocumentEx("C:\objekt.ai", openopt)
    ActivePage.SelectableShapes.All.CreateSelection
      ActiveSelection.Outline.SetProperties Color:=CreateRGBColor(0, 0, 0)
      ActiveSelection.Outline.SetProperties Width:=0
      ActiveSelection.Fill.ApplyUniformFill CreateRGBColor(0, 0, 0)
      For Each sl In ActiveSelection.Shapes: sl.Curve.Nodes.All.Smoothen 20
      Next
    grp1.Copy
    doc1.Close
    Dim pasteopt As StructPasteOptions
    Set pasteopt = CreateStructPasteOptions
    With pasteopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveDocument.Pages(1).Layers("Ebene 1").PasteEx(pasteopt)
End Sub

[koter]

Hallo Asterix,

Wir sollten uns ab jetzt an die Forenregel Nr. 5 halten:

Themenbezogene Beiträge
In den einzelnen Beiträgen sollte versucht werden, beim Thema zu bleiben und nach Möglichkeit sach- und themenbezogene Antworten zu geben. Es fällt sonst schwer, einem Thema zu folgen.

Es fällt mir tatsächlich schwer Deinen Beiträgen zu folgen.
Es geht nicht um die Anzahl der Beiträge in einem Thema sondern um die einzelnen Beiträge.

Ich verstoße jetzt noch einmal gegen die Regel und Versuche auf die Fragen, die ich mir merken konnte zu antworten:

Die PrecisionMargin ist der an die Methode AutoReduce übergebene Parameter.
Er wird in der Hilfe zur Methode erklärt.

Die Zwischenablage wird mit Clipboard.Clear geleert.

Auf Die Frage zur Smoothen-Methode bin ich in Beitrag 14 schon eingegangen.
Falls Du eine der beiden Möglichkeiten verwenden willst, aber nicht weißt wie, kann ich sie präzisieren.

Ich weiß nicht wie gut Du Dich mittlerweile mit VBA und dem CD-Objektmodell auskennst.
Deshalb können meine Antworten nicht immer Deinem Kenntnisstand entsprechen.
Ich will Dich ja auch nicht mit zu ausführlichen Antworten langweilen
oder gar Deinen Kenntnisstand beleidigen.

Gruß

Koter

[asterix]

Hallo Koter,

herzlichen Dank. Das mit der Zwischenablage funktioniert einwandfrei - zwei kleine Wörtchen, aber darauf muss man ja erstmal kommen.

Bezüglich meines Kenntnisstandes: Du kannst ihm 1:1 in diesem Thema folgen . Ich weiß nichts über VBA, was über mein hier Geschriebenes hinausgeht.

Und das führt auch genau zu dem hier aufgetretenen Phänomen: Ich habe einfach dazugelernt. Dadurch haben sich manche Fragen erledigt, manche neue Fragen kamen dazu. Aber es steht weiterhin alles unter dem gemeinsamen Thema, dem es folgt: Wie man manche Makro-Funktionen, die man hier und anderswo für einen bestimmten Anwendungsfall findet, eben allgemein für alle Objekte eines Dokuments nutzen kann.

Das hat auch alle perfekt geklappt, alle Fragen konnten geklärt werden.
Alle?
Nicht ganz .


Leider weiß ich nur eine Sache immer noch nicht. Wie kann ich in dem unten folgenden Gesamt-Code die Zeile

Code:

For Each sl In ActiveSelection.Shapes: sl.Curve.Nodes.All.Smoothen 20
Next

so korrigieren, dass sie für alle Objekte (Umrisse, Füllungen) funktioniert?

Ich kann aus deinen beiden bisherigen Antworten aufgrund meines mangelnden Wissens leider keinen Code ableiten.

Code:

Sub opencopy()
    ' Recorded 30.06.2024
    Dim lr1 As Layer
    Set lr1 = ActiveDocument.Pages(1).CreateLayer("Ebene 1")
    ' Recording of this command is not supported
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    impopt.MaintainLayers = True
    Dim impflt As ImportFilter
    Set impflt = lr1.ImportEx("C:\objekt.ai", 1283, impopt)
    impflt.Finish
    Dim s1 As Shape
    Set s1 = ActiveShape
    Dim grp1 As ShapeRange
    Set grp1 = ActiveSelection.UngroupEx
    Dim openopt As StructOpenOptions
    Set openopt = CreateStructOpenOptions
    With openopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim doc1 As Document
    Set doc1 = OpenDocumentEx("C:\objekt.ai", openopt)
    ActivePage.SelectableShapes.All.CreateSelection
      ActiveSelection.Outline.SetProperties Color:=CreateRGBColor(0, 0, 0)
      ActiveSelection.Outline.SetProperties Width:=0
      ActiveSelection.Fill.ApplyUniformFill CreateRGBColor(0, 0, 0)
      For Each sl In ActiveSelection.Shapes: sl.Curve.Nodes.All.Smoothen 20
      Next
    grp1.Copy
    doc1.Close
    Dim pasteopt As StructPasteOptions
    Set pasteopt = CreateStructPasteOptions
    With pasteopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveDocument.Pages(1).Layers("Ebene 1").PasteEx(pasteopt)
End Sub

[asterix]

...und wieder muss ich aufgrund der Lernkurve etwas direkt wieder abhaken .

Also, das hat nun auch geklappt, ich musste nur vorher die Gruppe / Kombination auflösen.
Es scheint ja auch so zu sein, dass diese erwähnte Zeile zum Smoothing auch für beides gilt, zumindest ging sie nun auch gut für die aus Umrissen konvertierten Objekte. 

Habe auch die Änderung der Objekte dann weiter nach unten gestellt.

Code:

Sub opencopy()
    Dim lr1 As Layer
    Set lr1 = ActiveDocument.Pages(1).CreateLayer("Ebene 1")
    ' Recording of this command is not supported
    Dim impopt As StructImportOptions
    Set impopt = CreateStructImportOptions
    impopt.MaintainLayers = True
    Dim impflt As ImportFilter
    Set impflt = lr1.ImportEx("C:\objekt.ai", 1283, impopt)
    impflt.Finish
    Dim s1 As Shape
    Set s1 = ActiveShape
    Dim grp1 As ShapeRange
    Set grp1 = ActiveSelection.UngroupEx
    Dim openopt As StructOpenOptions
    Set openopt = CreateStructOpenOptions
    With openopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim doc1 As Document
    Set doc1 = OpenDocumentEx("C:\objekt.ai", openopt)
    ActivePage.SelectableShapes.All.CreateSelection
      Clipboard.Clear
      grp1.Copy
      doc1.Close
    Dim pasteopt As StructPasteOptions
    Set pasteopt = CreateStructPasteOptions
    With pasteopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,ISO Coated v2 300% (ECI),Dot Gain 15%"
    End With
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveDocument.Pages(1).Layers("Ebene 1").PasteEx(pasteopt)
ActivePage.Shapes.All.CreateSelection   
ActiveSelection.Outline.SetProperties Color:=CreateRGBColor(0, 0, 0)
      ActiveSelection.Outline.SetProperties Width:=0
      ActiveSelection.Fill.ApplyUniformFill CreateRGBColor(0, 0, 0)
      ActivePage.SelectableShapes.All.CreateSelection
      ActivePage.Shapes.All.CreateSelection
    Set grp1 = ActiveSelection.UngroupAllEx
    ActiveSelection.BreakApartEx
    For Each s In ActiveSelection.Shapes: s.Curve.Nodes.All.Smoothen 10
      Next
End Sub

Also doch alle Fragen geklärt .
Wenn ich doch irgendwann eine Makro-Herausforderung haben werde, eröffne ich in jedem Fall ein neues Thema!

Danke nochmals, Koter, der große Nutzen für mich in diesem Thema war einfach, dass ich Objekte in CorelDraw reinkopieren wollte und diese dann automatisiert direkt bearbeiten. Daher die Sache mit dem "für alle Objekte". Denn es geht auch einfach um alle Objekte, die man einfach nur ein bisschen anpassen möchte nach dem Einfügen.

[koter]

Hallo Asterix,

...so korrigieren, dass sie für alle Objekte (Umrisse, Füllungen) funktioniert?...

streng genommen nicht, denn Umrisse und Füllungen haben keine Knoten.

Ich vermute jetzt, dass Dir das völlig egal ist und Du nur Code zum Kopieren und Einfügen willst.
(Was natürlich völlig in Ordnung wäre)

Versuche es mit diesem Code:

Code:

For Each s In ActiveSelectionRange.Shapes.FindShapes(Type:=cdrCurveShape):  s.Curve.Nodes.All.Smoothen 20: Next

Liege ich mit meiner Vermutung richtig?

Gruß

Koter