перемещение блоков

;; written by Fatty T.O.H (c) 2004
;; all rights removed
;; get ObjectDBX document
;; edited 4/20/06
;; edited 5/28/06 by Jeff M (see commented lines)
;; edited 10/5/06
;; edited 3/19/07
;; edited 3/20/07
(defun odbx-test (/ dbx_doc)
;; edited 5/28/06 by Jeff M
;; modified slightly to work with more versions
  (or (vl-load-com))
  (if (< (setq dbxver (atoi (getvar "ACADVER"))) 15)
    (progn (alert
         "ObjectDBX method not applicable\nin this AutoCAD version"
       )
       (exit)
       (princ)
       (gc)
    )
    (progn
      (if (= (atoi (getvar "ACADVER")) 15)
    (progn
      (if (not (vl-registry-read
             "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
           )
          )
        (startapp "regsvr32.exe"
              (strcat "/s \"" (findfile "axdb15.dll") "\"")
        )
      )
      (setq    dbx_doc    (vla-getinterfaceobject
              (vlax-get-acad-object)
              "ObjectDBX.AxDbDocument"
            )
      )
    )
    (setq dbx_doc (vla-getinterfaceobject
            (vlax-get-acad-object)
            (strcat "ObjectDBX.AxDbDocument." (itoa (fix dbxver)))
              )
    )
      )
    )
  )
)
;; main programm :
;; edited 7/10/07
(defun C:CBR (/ acapp acsp adoc blk fn fname fold
          full_name_list odbx other_doc)
  (vl-load-com)
  (or acapp
      (setq acapp (vlax-get-acad-object))
  )
  (or adoc
      (setq adoc (vla-get-activedocument acapp))
  )
(or acsp
      (setq acsp (if (= (getvar "CVPORT") 1)
           (vla-get-paperspace
             adoc)
           (vla-get-modelspace
             adoc)
           )
        )
      )
  (vla-startundomark adoc)
  (setq odbx (odbx-test))
    (setq    fn           (getfiled "Select *ANY .DWG FILE* in a desired folder : "
                 ""
                 "dwg"
                 4
               )
    fold           (vl-filename-directory fn)
    full_name_list (vl-directory-files fold "*.dwg" 1)
    full_name_list (mapcar (function (lambda (x)
                       (strcat fold "\\" x)
                     )
                   )
                   full_name_list
               )
  )
  (if (setq other_doc (odbx-test))
    ;;moved out of foreach
    (progn
      (foreach other full_name_list
    (if (setq fname (findfile other))
      (progn
        (vla-open other_doc fname)
        (vlax-for blk (vla-get-blocks other_doc)
          (vl-catch-all-apply
           (function
             (lambda ()
               (vla-copyobjects
             other_doc
             (vlax-safearray-fill
               (vlax-make-safearray vlax-vbobject '(0 . 0))
               (list blk)
             )
             (vla-get-blocks adoc)
               )
             )
           )
         )
          )
;;;        (vlax-invoke other_doc 'SaveAs fname)
;the next line does nothing for a ODBX doc
;;;(vl-catch-all-apply (function (lambda ()
;;;(vla-update acapp))))
      )
      (princ "\File Not Found")
    )
      )
    )
  )
  ;;moved following 2 lines out of foreach
  (vl-catch-all-apply
    (function (lambda ()
        (vlax-release-object other_doc)
          )
    )
  )
  (setq other_doc nil)
;no need for these next 2 lines
;(vla-setvariable adoc "SDI" mdmod)
;  (vla-endundomark adoc)
  (gc)
  (princ)
)
(princ "\n  Type CBR to run programm...")
(princ)

Option Explicit
'' Requires: (include usual DLLs)
'' AutoCAD/ObjectDBX Common 16.0 Type Library (or 17.0 for A2007)
'' Microsoft Scripting Runtime
'' |||||||||||||||||||||||''
'' |Tested on A2005 only |''
'' |||||||||||||||||||||||''
Public Function BrowseForFolderF(ByVal msg As String) As String
     Dim oBrowser, folderObj, folderAcpt As Object
     Dim folderStr As String
     Set oBrowser = ThisDrawing.Application.GetInterfaceObject("Shell.Application")
     Set folderAcpt = oBrowser.BrowseForFolder(vbOKOnly, msg, vbDefaultButton3, 0)
     With folderAcpt
          Set folderObj = .Self
          folderStr = folderObj.path
     End With
     Set folderObj = Nothing
     Set folderAcpt = Nothing
     Set oBrowser = Nothing
     BrowseForFolderF = folderStr
End Function
Public Function CheckFolder(ByVal strPath As String) As Variant
     Dim objFolder     ''As Scripting.Folder
     Dim objFile     ''As Scripting.File
     Dim objSubdirs     ''As Scripting.Folders
     Dim objLoopFolder     ''As Scripting.Folder
     Dim varFs() As Variant
     Dim m_objFSO, n, m_lngFileCount
     Debug.Print "Checking directory " & strPath
     Set m_objFSO = CreateObject("Scripting.FileSystemObject")
     Set objFolder = m_objFSO.GetFolder(strPath)
     '
     ' Check files in this directory
     '
     n = -1
     For Each objFile In objFolder.Files
          If UCase$(Right$(objFile.ShortPath, 4)) = ".DWG" Then
               m_lngFileCount = m_lngFileCount + 1
               n = n + 1
               ReDim Preserve varFs(n)
               varFs(n) = objFile.path
          End If
     Next objFile
     ' Loop through all subdirectories and
     ' do the same thing.
     '
     Set objSubdirs = objFolder.SubFolders
     For Each objLoopFolder In objSubdirs
          CheckFolder objLoopFolder.path
     Next objLoopFolder
     Set objSubdirs = Nothing
     Set objFolder = Nothing
     CheckFolder = varFs
End Function
Public Sub main()
     Dim oAxDoc As New AxDbDocument
     Dim iNdx As Integer, jNdx As Integer
     Dim iFiles() As Variant
     Dim m_objFSO
     Dim fold, DwgName As String, curName As String
     curName = ThisDrawing.FullName
     On Error GoTo Err_Control
     fold = BrowseForFolderF("Select folder to process files")
     Set m_objFSO = CreateObject("Scripting.FileSystemObject")
     iFiles = CheckFolder(fold)
     Select Case Left(ThisDrawing.GetVariable("ACADVER"), 2)
     Case Is = "17"
          Set oAxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
     Case Is = "16"
          Set oAxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
     Case Else
          Set oAxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument")
     End Select
     On Error Resume Next
     For iNdx = LBound(iFiles) To UBound(iFiles)
          DwgName = iFiles(iNdx)
          If DwgName <> curName Then
               oAxDoc.Open DwgName
               Dim objs() As Object
               Dim i As Integer
               For i = 0 To oAxDoc.Blocks.Count - 1
                    ReDim Preserve objs(i)
                    Set objs(i) = oAxDoc.Blocks(i)
               Next
               oAxDoc.CopyObjects objs, ThisDrawing.Blocks
          End If
     Next
Exit_Here:
     On Error Resume Next
     Set oAxDoc = Nothing
     Set m_objFSO = Nothing
     Exit Sub
Err_Control:
     If Err.Number <> 0 Then MsgBox Err.Description
     Resume Exit_Here
End Sub