Как программно скопировать все объекты в другой чертеж? (Страница 1 из 2)

Private Sub myCopy_Click(doc1 As acadDocument)
    Dim objSelCol As AcadSelectionSets
    Set objSelCol = ThisDrawing.SelectionSets
    Dim doc2 As AcadDocument
    Set doc2 = New AcadDocument
    Call doc1.CopyObjects(objSelCol, doc2)
    doc2.Activate
End Sub

Private sub my_copy(doc1 as AcadDocument)
    Dim objSelSet As AcadSelectionSet
    Dim objEnt As AcadEntity
    Dim doc2 As AcadDocument
    Dim allObj() As Variant
    Dim i As Long
    Set doc2 = New AcadDocument
    doc1.Activate
    Set objSelSet = vbdPowerSet("processall")
    objSelSet.Select acSelectionSetAll
    i = 0
    For Each objEnt In objSelSet
        ReDim Preserve allObj(i + 1) As Variant
        Set allObj(i) = objEnt
        i = i + 1
    Next
    Call doc1.CopyObjects(allObj, doc2)
    doc2.Activate
end sub
Private Function vbdPowerSet(strName As String) As AcadSelectionSet
    Dim objSelSet As AcadSelectionSet
    Dim objSelCol As AcadSelectionSets
    Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
        If objSelSet.name = strName Then
            objSelSet.Delete
            Exit For
        End If
    Next
    Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
    Set vbdPowerSet = objSelSet
End Function

Set pACD = Documents.Add

Sub aa()
Dim pACD1 As AcadDocument, pACD2 As AcadDocument
Dim pACD As AcadDocument
Static pNDoc As Long
Dim pE As AcadEntity
    On Error GoTo erhan
    If pNDoc = Documents.Count - 1 Then pNDoc = 0
    Set pACD1 = Documents.Item(pNDoc)
    pNDoc = pNDoc + 1
    If MsgBox("Вставляю файл " & pACD1.Name, vbOKCancel) = vbCancel Then Exit Sub
    Set pACD = Documents.Item(Documents.Count - 1)
    For Each pE In pACD1.ModelSpace
        CopyToBlock pE, pACD.ModelSpace
    Next pE
    pACD.Activate
    Update
    ZoomAll
    MsgBox "Вставлен файл " & pACD1.Name & vbCrLf & "Всё видно?"
    Exit Sub
erhan:
    MsgBox Err.Description
    If Err Then Err.Clear
End Sub
Public Function CopyToBlock(Ent As AcadEntity, _
             ToBlock As AcadBlock, Optional ByVal ErrResult As String, Optional NewBase = Null) As AcadEntity
Dim t0(2) As Double, t1(2) As Double
Dim pAO(0) As AcadEntity
Dim pRet, pIdP
Dim pACD As AcadDocument
    Set pACD = Ent.Document
    Set pAO(0) = Ent
    pRet = pACD.CopyObjects(pAO, ToBlock, pIdP)
    If Not IsNull(NewBase) Then
        On Error Resume Next
            t0(0) = NewBase(0)
            t0(1) = NewBase(1)
            t0(2) = NewBase(2)
            pRet(0).Move t0, t1
        If Err Then Err.Clear
    End If
    Set CopyToBlock = pRet(0)
End Function 

Public Sub PrintMessage(MessageString As String)
Dim pEchoVal As Integer
    pEchoVal = ThisDrawing.GetVariable("CMDECHO")
    ThisDrawing.SetVariable "CMDECHO", 1
    ThisDrawing.Utility.Prompt MessageString
    ThisDrawing.SetVariable "CMDECHO", pEchoVal
End Sub
Public Function CopyToBlock(Ent As AcadEntity, _
             ToBlock As AcadBlock, Optional ByVal ErrResult As String, Optional NewBase = Null) As AcadEntity
Dim t0(2) As Double, t1(2) As Double
Dim pAO(0) As AcadEntity
Dim pRet, pIdP
Dim pACD As AcadDocument
    On Error Resume Next
    Set pACD = Ent.Document
    Set pAO(0) = Ent
    pRet = pACD.CopyObjects(pAO, ToBlock, pIdP)
    If Not IsNull(NewBase) Then
        t0(0) = NewBase(0)
        t0(1) = NewBase(1)
        t0(2) = NewBase(2)
        pRet(0).Move t0, t1
    End If
    If Err Then
        If Not IsMissing(ErrResult) Then ErrResult = Err.Description Else ErrResult = ""
        Err.Clear
    End If
    Set CopyToBlock = pRet(0)
End Function
Sub aa()
Dim pACDDest As AcadDocument
Dim pACD As AcadDocument
Dim pErrRes As String
Dim pNErr As Long
Dim pE As AcadEntity
    PrintMessage vbCrLf & ">>>>>>>Начало работы AA"
    Set pACDDest = Documents.Add
    pACDDest.Activate
    PrintMessage vbCrLf & "Создали документ " & pACDDest.Name
    If Documents.Count = 1 Then Exit Sub
    For Each pACD In Documents
        If Not pACD Is pACDDest Then
            PrintMessage vbCrLf & "Копируем файл " & pACD.Name
            pNErr = 0
            For Each pE In pACD.ModelSpace
                CopyToBlock pE, pACDDest.ModelSpace, pErrRes
                If pErrRes <> "" Then pNErr = pNErr + 1
            Next pE
            If pNErr > 0 Then
                PrintMessage vbCrLf & "Ошибок при вставке файла " & pNErr
            Else
                PrintMessage "   Успешно!"
            End If
        End If
    Next pACD
    pACDDest.Activate
    Update
    ZoomAll
    PrintMessage vbCrLf & "<<<<<<<Конец работы AA"
End Sub

Dim pACA As AcadApplication
    Set pACA = CreateObject("AutoCAD.Application")
    pACA.Visible = True

Dim pACA As AcadApplication
Set pACA = CreateObject("AutoCAD.Application")
pACA.Visible = True
Set pACDDest = pACA.Documents.Add
If Documents.Count = 1 Then Exit Sub
For Each pACD In Documents
    If Not pACD Is pACDDest Then pNErr = 0
    For Each pE In pACD.ModelSpace
           ...
    Next pACD
next