hallo Oli,
war auf der Suche nach derselben Aufgabenstellung
Mit Hikfe folgendem Werk wird alles im Block auf Phantomlayer modifiziert
mit freundlichem Gruss
Hans Krissler
Public Sub PhantomBlock()
Rem aktuelle Zeichnung
Dim Dok As AcadDocument
Set Dok = ThisDrawing.Application.ActiveDocument
DokName = Dok.Name
Rem Block selektieren
Dim Auswahl(0) As Object
On Error GoTo errhandler
ThisDrawing.Utility.GetEntity Auswahl(0), basepnt, vbCrLf & "Block auswählen: "
If Auswahl(0).ObjectName = "AcDbBlockReference" Then
Dim AuswahlBlock As AcadBlockReference
Set AuswahlBlock = Auswahl(0)
Dim AuswahlBlockName As String
AuswahlBlockName = AuswahlBlock.Name
Dim InsertionPnt(0 To 2) As Double
InsertionPnt(0) = AuswahlBlock.InsertionPoint(0)
InsertionPnt(1) = AuswahlBlock.InsertionPoint(1)
InsertionPnt(2) = AuswahlBlock.InsertionPoint(2)
Rem Block-Manipulation wird in einer Dummy-Zeichnung ausgeführt
Dim DokDummy As AcadDocument
Set DokDummy = Documents.Add
Rem Block in Dummy-Zeichnung
Dim RetVal As Variant
RetVal = Documents.Item(Dok.Name).CopyObjects(Auswahl, ThisDrawing.ModelSpace)
ThisDrawing.Application.ZoomExtents
Rem kein Block ausgewählt
Else: MsgBox "Auswahl war kein Block", vbExclamation
GoTo errhandler
End If
Rem Block in Elemente zerlegen
Nochmal:
For Each Auswahl(0) In ThisDrawing.ModelSpace
If (Auswahl(0).ObjectName = "AcDbBlockReference") Then
Auswahl(0).Explode
Auswahl(0).Delete
Rem nach Blockzerlegung kann der Block nochmals einen Block enthalten :
GoSub Nochmal
End If
Next
Rem Zerlegung Schrauben und Sonstiges
ThisDrawing.SendCommand "_Explode" & vbCr & "Alle" & vbCr & vbCr
Rem AuswahlSatz Alles
Dim SSet As AcadSelectionSet
Set SSet = ThisDrawing.SelectionSets.Add("Brutto")
SSet.Select acSelectionSetAll
Rem Objekte aus Auswahlsatz der Objektliste zuordnen
ReDim SSetListe(SSet.Count - 1) As Object
For i = 0 To SSet.Count - 1
Set SSetListe(i) = SSet.Item(i)
Next
Rem beim Auflösen entstehen ominöse Objekte, die können wir einfach löschen
For i = 0 To SSet.Count - 1
If SSet.Item(i).Layer = "-BHMU" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "BHII" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "BHMM" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "CENN" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "CON1" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "HIDN" Then
SSet.Item(i).Delete
ElseIf SSet.Item(i).Layer = "THLI" Then
SSet.Item(i).Delete
End If
Next
Rem LayerWechsel
ThisDrawing.SendCommand "_AMLayMove" & vbCr & "Alle" & vbCr & vbCr & "AM_11" & vbCr
Rem neuen Block (bestehend aus Phantom-Elementen) erstellen
Dim ReBlock(0) As Object
Set ReBlock(0) = ThisDrawing.Blocks.Add(InsertionPnt, "Phantom-" & AuswahlBlockName)
Dim ReBlockName As String
ReBlockName = ReBlock(0).Name
Set SSet = ThisDrawing.SelectionSets.Add("Netto")
SSet.Select acSelectionSetAll
Rem Objekte aus Auswahlsatz der Objektliste zuordnen
ReDim SSetListe(SSet.Count - 1) As Object
For i = 0 To SSet.Count - 1
Set SSetListe(i) = SSet.Item(i)
Next
Rem aus oben gebildetem Auswahlsatz den "Phantom-Block" erstellen
RetVal = DokDummy.CopyObjects(SSetListe, ReBlock(0))
Rem Phantom-Block zurück in Ausgangszeichnung kopieren
RetVal = Documents.Item(DokDummy.Name).CopyObjects(ReBlock, Dok.ModelSpace)
Rem Ursprungs-Zeichnung aktivieren
Dok.Activate
Rem Dummy-Zeichnung schliessen
DokDummy.Close
Rem Phantom-Block einfügen
Set ReBlock(0) = ThisDrawing.ModelSpace.InsertBlock(InsertionPnt, ReBlockName, 1, 1, 1, 0)
Rem Ursprungs-Block löschen
AuswahlBlock.Delete
Rem ein paarmal Bereinigen ausführen
For i = 1 To 4
ThisDrawing.PurgeAll
Next i
errhandler:
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP