代理实体

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)
  Dim block As AcadBlock
  For Each block In sourceDoc.Blocks
    If block.IsLayout Then
      Dim index As Long
      Dim objects() As AcadObject
      index = -1
      ReDim objects(0 To block.Count) As AcadObject
      Dim ent As AcadEntity
      For Each ent In 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
        ReDim Preserve objects(index) As AcadObject
        sourceDoc.CopyObjects objects, targetDoc.Blocks(block.Name)
      End If
    End If
  Next block
  Set block = Nothing
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