Как программно выполнить перенос блока в другой документ ?

Option Explicit
'' Note
'' Requires reference to:
'' Visual Basic For Applications
'' AutoCAD 2005 Type Library
'' Ole Automation
'' Microsoft Forms 2.0 Object Library
'' AutoCAD/ObjectDBX Common 16. Type Library
'' Copy and insert block from other drawing
'' written by Fatty T.O.H. (c)2006
'' All rights removed
'' Insert UserForm with name frmDBXBlocks,
'' add in this form 1 ListBox and 3 CommandButtons
Dim oDbx As New AxDbDocument
Dim fname As String
Dim sBlkName As String
'' F.T.O.H.
Function GetBlocks(FileName As String) As Variant
Dim i As Integer
Dim blkVar() As String
Dim objDBX As New AxDbDocument
objDBX.Open FileName
Dim objEnt As AcadBlock
i = -1
For Each objEnt In objDBX.Blocks
If Not objEnt.IsXRef And Not objEnt.IsLayout And _
Not objEnt.Name Like "*,*|*" Then
i = i + 1
ReDim Preserve blkVar(i)
blkVar(i) = objEnt.Name
End If
Next
Set objDBX = Nothing
GetBlocks = blkVar
End Function '' ok
'' F.T.O.H.
Public Sub CopyBlock(fname As String, bName As String)
Set oDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")
oDbx.Open fname
Dim oBlocks As AcadBlocks
Dim oBlock As AcadBlock
Dim copyVar(0) As AcadBlock
Set oBlocks = oDbx.Blocks
Set oBlock = oBlocks.Item(bName)
Set copyVar(0) = oBlock
On Error GoTo HoustonWeHaveAProblem
Dim idPairs As Variant
Dim copyObj As Variant
copyObj = oDbx.CopyObjects(copyVar, ThisDrawing.Blocks, idPairs)
Set oDbx = Nothing
HoustonWeHaveAProblem:
If Err.Number <> 0 Then
MsgBox "ObjectDBX CopyObjects method objects failed." & vbCr & Err.Number & " " & _
Err.Description, vbCritical
End If
End Sub '' ok
Private Sub CommandButton1_Click()
Call CopyBlock(fname, sBlkName)
CommandButton1.ForeColor = vbBlack
CommandButton2.SetFocus
CommandButton2.ForeColor = vbRed
End Sub
Private Sub CommandButton2_Click()
Dim blkRef As AcadBlockReference
Dim pickPt As Variant
frmDBXBlocks.hide
pickPt = ThisDrawing.Utility.GetPoint(, vbCr & "Insertion point :")
Set blkRef = ThisDrawing.ModelSpace.InsertBlock(pickPt, sBlkName, 1#, 1#, 1#, 0#)
blkRef.Update
CommandButton2.ForeColor = vbBlack
CommandButton3.SetFocus
CommandButton3.ForeColor = vbRed
frmDBXBlocks.Show
End Sub
Private Sub CommandButton3_Click()
Unload Me
End
End Sub
Private Sub ListBox1_Click()
Dim i As Integer
Dim cBlock As AcadBlock
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
sBlkName = ListBox1.Value
End If
Next i
For Each cBlock In ThisDrawing.Blocks
If StrComp(UCase(sBlkName), UCase(cBlock.Name), 1) = 0 Then
MsgBox "This block already exist"
CommandButton1.ForeColor = vbBlack
CommandButton2.SetFocus
CommandButton2.ForeColor = vbRed
Exit For
Else
CommandButton1.SetFocus
CommandButton1.ForeColor = vbRed
End If
Next
End Sub
Private Sub UserForm_Initialize()
frmDBXBlocks.Caption = "Copy/Insert Block From Library"
CommandButton1.Caption = "Copy Block"
CommandButton2.Caption = "Insert Block"
CommandButton3.Caption = "Done/Exit"
Dim bVar() As String
fname = ThisDrawing.Path & "\" & "CHECKS.dwg"
'' <- change block library name here
bVar = GetBlocks(fname)
ListBox1.Clear
ListBox1.ColumnCount = 1
ListBox1.List() = bVar
End Sub

Option Explicit
Sub RunMe()
frmDBXBlocks.Show
End Sub