Code:
Option ExplicitSub 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
Foren auf CAD.de (alle Foren)
| 
, 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. 
