Next iteration:
Option Explicit
Private Const ERR_DUPLICATE_KEY As Long = -2145386475
Sub main()
Dim sourceDoc As AcadDocument
Dim targetDoc As AcadDocument
Set sourceDoc = Application.ActiveDocument
Set targetDoc = Documents.Add
scanObjects sourceDoc, targetDoc
Application.ZoomExtents
Set targetDoc = Nothing
End Sub
Private Sub scanObjects(ByRef sourceDoc As AcadDocument, _
ByRef targetDoc As AcadDocument)
On Error GoTo ERROR_HANDLER
Dim sourceBlock As AcadBlock
For Each sourceBlock In sourceDoc.Blocks
If Not sourceBlock.IsLayout And _
Not sourceBlock.IsXRef And _
Left(sourceBlock.Name, 1) <> "*" Then
Dim index As Long
Dim objects() As AcadObject
index = -1
ReDim objects(0 To sourceBlock.Count) As AcadObject
Dim ent As AcadEntity
For Each ent In sourceBlock
If ent.ObjectName <> "AcDbZombieEntity" Then
If ent.HasExtensionDictionary Then
scanDictionary ent.GetExtensionDictionary
End If
index = index + 1
Set objects(index) = ent
End If
Next ent
Set ent = Nothing
If index > -1 Then
Dim targetBlock As AcadBlock
Set targetBlock = targetDoc.Blocks.Add(sourceBlock.Origin, sourceBlock.Name)
ReDim Preserve objects(index) As AcadObject
sourceDoc.CopyObjects objects, targetBlock
End If
End If
Next sourceBlock
Set sourceBlock = Nothing
Dim sourceLayout As AcadLayout
For Each sourceLayout In sourceDoc.Layouts
index = -1
ReDim objects(0 To sourceLayout.block.Count) As AcadObject
For Each ent In sourceLayout.block
If ent.ObjectName <> "AcDbZombieEntity" Then
If ent.HasExtensionDictionary Then
scanDictionary ent.GetExtensionDictionary
End If
index = index + 1
Set objects(index) = ent
End If
Next ent
Set ent = Nothing
If index > -1 Then
Dim targetLayout As AcadLayout
Set targetLayout = targetDoc.Layouts.Add(sourceLayout.Name)
ReDim Preserve objects(index) As AcadObject
sourceDoc.CopyObjects objects, targetLayout.block
End If
Next sourceLayout
Set sourceLayout = Nothing
Exit Sub
ERROR_HANDLER:
Select Case Err
Case ERR_DUPLICATE_KEY
Set targetLayout = targetDoc.Layouts(sourceLayout.Name)
Resume Next
Case Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Select
End Sub
Sub scanDictionary(ByRef dictionary As AcadDictionary)
Dim obj As AcadObject
For Each obj In dictionary
If TypeOf obj Is AcadDictionary Then
scanDictionary obj
ElseIf obj.ObjectName Like "AcDbZombie*" Then
obj.Delete
ElseIf obj.HasExtensionDictionary Then
scanDictionary obj.GetExtensionDictionary
End If
Next obj
Set obj = Nothing
End Sub