Rem Elemente eines Blocks auf Layer AM_11 (Phantom-Layer)
Rem Entwicklung auf AM2004
Rem ib-krissler
Rem 09.09.05

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