Skizziertes Symbol ersetzen, WithLeader (Autodesk/Inventor VBA)

20201117_vba_skSymbErsetzen.idw

Da ich nun schon eine Weile an diesem Problem knabbere, könnte ich Hilfe gebrauchen. Bereits jetzt vielen Dank fürs Lesen.

In der geöffneten Zeichnung soll ein skizziertes Symbol durch ein anderes ersetzt werden. Meist wird das Symbol mit einer (1) Führungslinie (Leader) an einem Objekt hängen. Mehr als ein Leader muss nicht von diesem Makro abgedeckt werden.

Ursprünglich habe ich versucht, nur die .Definition des vorhandenen Symbols auf die neue Definition zu ändern. Das hat aber nicht geklappt. Hier könnte schon die Lösung liegen: Ist das Ändern der Definition doch möglich? Wie macht das die DIVA Scherzhafte Bezeichnung für Inventor IV , wenn man von Hand das Symbol doppelt klickt (oder Kontextmenü "Symbol bearbeiten") und ein anderes Symbol auswählt? Dabei bleiben die Führungslinien ja auch wie sie sind.

Der aktuelle Plan ist, das Symbol neu zu erstellen. Dabei Inhalt und Position vom vorhandenen Symbol zu übernehmen. Das klappt, wenn es keine Führungslinie gibt, oder auch wenn die Führungslinie nicht an einem Objekt hängt. Es klappt aber nicht, wenn die Führungslinie am 'falschen' Objekt hängt. Bisher bin ich auf zwei Arten von Problemen gestoßen:

Problem A: bei einem Bezugssymbol
hier scheint es kein 'richtiges' AttachedEntity (oSkSymbVorh.Leader.AllLeafNodes.Item(1).AttachedEntity) zu geben

Problem B: bei Form- und Lagetoleranzen, Oberflächensymbolen, anderen skizz.Symbolen
hier schlägt das Erstellen des neuen Symbols fehl. Obwohl bis dahin (für mich) alles gut aussieht

Ich habe ein Beispiel angehängt, das diese Fälle enthält. Der Code ist auch enthalten. Ich füge ihn aber trotzdem hier ein.

Code:
Option Explicit
Sub idw_IndexSymb_ersetzen()
' KraBBy 17.11.2020
Const sQSname = "Symb_alt" 'Name des vorhandenen, alten Symbols, das ersetzt werden soll
Const sIndexSymb = "Symb_neu" 'Name des neuen Symbols
'Verweis auf aktives Dokument
Dim oDoc As DrawingDocument 'Document
Set oDoc = ThisApplication.ActiveDocument

'SelectSet des aktiven Dokuments
Dim oSel As SelectSet
Set oSel = oDoc.SelectSet
If Not 0 = oSel.Count Then oSel.Clear 'ggf. Markierung aufheben

'Definition vom neuen Symb
Dim oSketchSymDef As SketchedSymbolDefinition
Set oSketchSymDef = oDoc.SketchedSymbolDefinitions.Item(sIndexSymb)
If oSketchSymDef Is Nothing Then Exit Sub 'etwas hat nicht geklappt

'Vorbereiten einer Collection mit den "alten Symbolen", werden am Ende gelöscht
Dim oCol2Del As ObjectCollection
Set oCol2Del = ThisApplication.TransientObjects.CreateObjectCollection

'Alle Aktionen zum Ersetzen in eine Rückgängig-Aktion packen
Dim oTxn As Transaction
Set oTxn = ThisApplication.TransactionManager.StartTransaction(oDoc, "Makro 'Symb. ersetzen'") 'Start oTxn

'Schleife durch alle Symb auf aktivem Blatt
Dim oSymb As SketchedSymbol
For Each oSymb In oDoc.ActiveSheet.SketchedSymbols
If oSymb.Name = sQSname Then
'SymbolDefinition ändern, wenn Name passt

Call oSel.Select(oSymb) 'markieren (nur damit man sieht um welches Symb. es gerade geht)
'Set oSymb.Definition = oSketchSymDef 'Definition umsetzen geht nicht!!!?

If replaceSkSymb(oDoc, oSymb, oSketchSymDef) Then 'Aufruf der Function unten und Erfolg
Call oCol2Del.Add(oSymb) 'zur Collection hinzufügen
End If

oSel.Clear 'Markierung(en) aufheben
'Else: 'nix, es geht weiter mit dem nächsten Symb.
End If
Next 'oSymb

'Transaction beenden und neue starten zum Löschen der ersetzten Symbole
oTxn.End
Set oTxn = ThisApplication.TransactionManager.StartTransaction(oDoc, "Makro 'ersetzte Symb. löschen'") 'Start oTxn

'ersetzte Symbole löschen
For Each oSymb In oCol2Del
Call oSymb.Delete
Next

oTxn.End '2. Transaction beenden
End Sub
Private Function replaceSkSymb(oDoc As DrawingDocument, oSkSymbVorh As SketchedSymbol, _
oSkSymbDefNeu As SketchedSymbolDefinition) As Boolean
' vorhandenes skizziertes Symbol ersetzen durch ein anderes
' Anzahl angeforderter Eingaben muss übereinstimmen
' es wird ein neues Symb. erstellt, das bisherige bleibt (ggf. im Aufruf löschen)
'
' oDoc : (aktives) Drawing-Dokument
' oSkSymbVorh : vorhandenes Skizz.Symbol mit oder ohne Leader
' oSkSymbDefNeu : Definition des neuen Symbols (muss bereits in oDoc vorhanden sein
'
' Rückgabewert True: Aufruf erfolgreich, keine Probleme erkannt
' Rückgabewert False: Fehler aufgetreten, Function wurde vorzeitig verlassen etc.
'
' KraBBy 09.11.2020

replaceSkSymb = False 'Default Rückgabewert der Funktion

'Anzahl angeforderte Eingaben und entspr. Array vorbereiten
Dim iPrompts As Integer, sPrompts() As String
'[...] hier im Bsp. keine Eingabefelder

Dim oSkSymbNeu As SketchedSymbol 'wird neues Symbol

On Error GoTo 0 'Fehlerbehandlung aus, um zu sehen, dass hier nix schief geht
If oSkSymbVorh.Leader.HasRootNode Then 'Symbol hat einen Leader

Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection()

Dim oNode As LeaderNode
For Each oNode In oSkSymbVorh.Leader.AllNodes
Call oLeaderPoints.Add(oNode.Position.Copy) ' .Copy hinzu um unabhängigen Punkt zu erhalten
Next oNode

Dim oGeometryIntent As GeometryIntent

On Error GoTo err_handler_P1
If oSkSymbVorh.Leader.AllLeafNodes.Item(1).AttachedEntity Is Nothing Then
'das Symb hängt an keinem Objekt
' dann hier nix zu tun
Else
On Error GoTo 0 'Fehlerbehandlung aus, um zu sehen, dass hier nix schief geht
'hängt an einem Objekt
Call oLeaderPoints.Remove(oLeaderPoints.Count) 'letzte Node entf, das wird der GeometryIntent
With oSkSymbVorh.Leader.AllLeafNodes.Item(1).AttachedEntity
Set oGeometryIntent = oDoc.ActiveSheet.CreateGeometryIntent(.Geometry, .Intent) 'liegt hier der Hund begraben? [Intent] lässt vieles zu
End With
Call oLeaderPoints.Add(oGeometryIntent)
End If

On Error GoTo err_handler_P2
Set oSkSymbNeu = oDoc.ActiveSheet.SketchedSymbols.AddWithLeader(oSkSymbDefNeu, oLeaderPoints, oSkSymbVorh.Rotation, 1)
'-> Scale auf 1 gesetzt, im Bsp. keine [PromtStrings]
' funktioniert, wenn Symb an Linie, oder Maß hängt;
' NICHT aber bei FormLageToleranz!
' NICHT aber bei SkizzSymbol!
' WARUM???

'Leader visible analog zur Vorlage
oSkSymbNeu.LeaderVisible = oSkSymbVorh.LeaderVisible

Else 'kein Leader
Set oSkSymbNeu = oDoc.ActiveSheet.SketchedSymbols.Add(oSkSymbDefNeu, oSkSymbVorh.Position, oSkSymbVorh.Rotation, 1)
'-> Scale auf 1 gesetzt, im Bsp. keine [PromtStrings]
End If
On Error GoTo 0 'Fehlerbehandlung aus, um zu sehen, dass hier nix schief geht

'Statisch ja/nein analog zur Vorlage?
'oSkSymbNeu.Static = oSkSymbVorh.Static
oSkSymbNeu.Static = True 'generell statisch!

'Rückgabe
replaceSkSymb = True
Exit Function

'Fehlerbehandlung
err_handler_P1:
MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, "Fehler A"
'Stop
Exit Function
err_handler_P2:
MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, "Fehler B"
'Stop
End Function

------------------
Gruß KraBBy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

cseTools Kanalkataster CAD APP für Tiefbau, AEC - Architektur-, Ingenieur- und Bauwesen