Как собрать несколько файлов dwg в один файл dwg?

Option Explicit
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXPLORER = &H80000
'Don 't change Windows's current directory to match the one chosen in the dialog box.
Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
Const mstrНазваниеПрограммы As String = "Объединение файлов"
Dim mlngОтвет As Long
Public Sub ОбъединитьФайлы()
'Подпрограмма просит выделить несколько чертежей и вставляет их в виде блоков в текущий чертёж в одну линию
Dim intНомЧертежа As Integer, intКолвоЧертежей As Integer
Dim colСписокЧертежей As Collection, vСписокФайлов As Variant
Dim objБлокЧертежа As AcadExternalReference
Dim insertionPnt(0 To 2) As Double
Dim vТочка As Variant
Dim lngНомОбъекта As Long, objОбъектЧертежа As AcadObject
Dim vminExt As Variant, vmaxExt As Variant, blnПризнакПолученияНачКоординат As Boolean
Dim dblЛеваяНижняяТочка(0 To 2) As Double, dblПраваяВерхняяТочка(0 To 2) As Double
Dim dblШирина As Double, dblВысота As Double
On Error GoTo ОбработкаОшибок
'Выведем диалоговое окно открытия файлов и попросим выбрать чертежи
   Set vСписокФайлов = ShowOpen("Чертежи AutoCAD  (*.dwg)" + Chr$(0) + "*.dwg" + Chr$(0) + _
      "Чертежи AutoCAD  (*.dxf)" + Chr$(0) + "*.dxf" + Chr$(0), "Выбери файлы объединяемых чертежей")
   If VarType(vСписокФайлов) = vbEmpty Then
      MsgBox "Наверное выбрано слишком много файлов", vbInformation, mstrНазваниеПрограммы
      Exit Sub
   End If
'Получим точку вставки
ПолучитьТочкуВставки:
   vТочка = ThisDrawing.Utility.GetPoint(, "Укажи точку вставки:")
   If Err.Number <> 0 Then
      mlngОтвет = MsgBox("Продолжать выбирать точку вставки?", vbYesNo, mstrНазваниеПрограммы)
      If mlngОтвет = vbYes Then
         Err.Clear
         GoTo ПолучитьТочкуВставки
      ElseIf mlngОтвет = vbNo Then
         Exit Sub
      End If
   End If
'Для каждого чертежа определим ширину и вставим блок
   For intНомЧертежа = 2 To vСписокФайлов.Count
'Создадим новый блок
      Set objБлокЧертежа = ThisDrawing.ModelSpace.AttachExternalReference(vСписокФайлов(1) & "\" & vСписокФайлов(intНомЧертежа), vСписокФайлов(intНомЧертежа), vТочка, 1, 1, 1, 0, False)
'Получим координаты крайних точек чертежа
      objБлокЧертежа.GetBoundingBox vminExt, vmaxExt
      dblЛеваяНижняяТочка(0) = vminExt(0)
      dblЛеваяНижняяТочка(1) = vminExt(1)
      dblПраваяВерхняяТочка(0) = vmaxExt(0)
      dblПраваяВерхняяТочка(1) = vmaxExt(1)
      dblШирина = (dblПраваяВерхняяТочка(0) - dblЛеваяНижняяТочка(0))
'      dblВысота = (dblПраваяВерхняяТочка(1) - dblЛеваяНижняяТочка(1))
      ThisDrawing.Blocks.Item(objБлокЧертежа.Name).Bind False
      vТочка(0) = vТочка(0) + dblШирина
   Next intНомЧертежа
   MsgBox "Было вставлено " & vСписокФайлов.Count - 1 & " файлов", vbInformation, mstrНазваниеПрограммы
   Exit Sub
ОбработкаОшибок:
   MsgBox "При объединении файлов произошла ошибка:" & vbLf & _
          "номер = " & Err.Number & vbLf & _
          "с описанием: " & Err.Description, vbExclamation, mstrНазваниеПрограммы
   Resume Next
End Sub
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Private Function ShowOpen(strFilter As String, strTitle As String) As Variant
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.hWnd
  VertName.lpstrFilter = strFilter
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = strTitle
  VertName.flags = OFN_ALLOWMULTISELECT + OFN_EXPLORER
  If GetOpenFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    Set ShowOpen = ПолучитьСемействоПодстрок(Left(strTemp, Len(strTemp) - 1), Right(strTemp, 1))
  End If
End Function
Private Function ПодсчётКоличестваЛексем(ByVal strТекст As String, ByVal strРаделитель As String) As Long
'Фунция определения числа появлений строки strРаделитель в строке strТекст (стр. 61 "Программирование в Microsoft Office. Полное руководство по VBA")
Dim lngКоличество As Long
Dim lngНачПозиция As Long
'Если не задана строка для поиска, то, естественно,
'ничего не может быть найдено, таким образом возвращается 0
   If VBA.Len(strТекст) > 0 Then
      lngНачПозиция = 1
      Do
         lngНачПозиция = VBA.InStr(lngНачПозиция, strТекст, strРаделитель, vbTextCompare)
         If lngНачПозиция > 0 Then
            lngКоличество = lngКоличество + 1
            lngНачПозиция = lngНачПозиция + VBA.Len(strРаделитель)
         End If
      Loop While lngНачПозиция > 0
   Else
      lngКоличество = 0
   End If
   ПодсчётКоличестваЛексем = lngКоличество
End Function
Private Function ВыделениеЗаданнойПодстроки(ByVal strТекст As String, ByVal lngНомСлова As Long, _
   ByVal strРазделители As String) As String
'Функция выделения лексем из списка с разделителями (стр. 85 "Программирование в Microsoft Office. Полное руководство по VBA")
'Список содержится в переменной strТекст
'а параметр lngНомСлова определяет, какой из фрагментов выделять
Dim lngНомПозиции As Long
Dim lngПрошлаяПозиция As Long
Dim lngНомНайденногоСлова As Long
Dim lngНайденнаяПозиция As Long
   lngНомПозиции = 1
   lngПрошлаяПозиция = -Len(strРазделители) + 1
   lngНомНайденногоСлова = lngНомСлова
   Do While lngНомНайденногоСлова > 0
      lngПрошлаяПозиция = lngНомПозиции
      lngНайденнаяПозиция = VBA.InStr(lngНомПозиции, strТекст, strРазделители)
      If lngНайденнаяПозиция > 0 Then
         lngНомПозиции = lngНайденнаяПозиция + Len(strРазделители)
         lngНомНайденногоСлова = lngНомНайденногоСлова - 1
      Else
         Exit Do
      End If
   Loop
'Если искомой строки не обнаружено,
'Данная итерация не была первой
'(в этом случае значения lngНомНайденногоСлова и lngНомСлова были бы равны)
'и lngНомНайденногоСлова > 1, то вы закончили просмотр лексем, не найдя нужную
'Это означает, что номер лексемы был слишком большим
'В таком случае возвращается ""
   If (lngНайденнаяПозиция = 0) And (lngНомНайденногоСлова <> lngНомСлова) And (lngНомНайденногоСлова > 1) Then
      ВыделениеЗаданнойПодстроки = ""
   Else
      ВыделениеЗаданнойПодстроки = VBA.Mid$(strТекст, lngПрошлаяПозиция, lngНайденнаяПозиция - lngПрошлаяПозиция)
   End If
End Function
Private Function ПолучитьСемействоПодстрок(ByVal strТекст As String, ByVal strРаделитель As String) As Variant
'Возвращает семейство, содержащее все лексемы строки,
'используя указанные разделители (стр. 91 "Программирование в Microsoft Office. Полное руководство по VBA")
Dim colКоллекцияЛексем As New Collection
Dim lngНомЛексемы  As Long
Dim strВременнаяСтрока  As String
Dim lngКолвоЛексем As Long
Dim strСимвол As String * 1
'Определяется количество лексем в заданной строке
   lngКолвоЛексем = ПодсчётКоличестваЛексем(strТекст, strРаделитель)
'Цикл по всем лексемам с добавлением их к выходному семейству
   For lngНомЛексемы = 1 To lngКолвоЛексем
      strВременнаяСтрока = ВыделениеЗаданнойПодстроки(strТекст, lngНомЛексемы, strРаделитель)
      colКоллекцияЛексем.Add strВременнаяСтрока, strВременнаяСтрока
   Next lngНомЛексемы
   'Возврат выходного семейства
   Set ПолучитьСемействоПодстрок = colКоллекцияЛексем
End Function