Копирование блоков из файла в файл через ActiveX

;;;* Утилита импорта и вставки блока из другого рисунка *
;;;-----------------------------------------------------
;;;
;;; Позволяет вставить блок из другого рисунка, выбранный
;;; в списке из окна диалога
;;; Файл диалого создается динамически как временный,
;;; после вывполнения программы удаляется
;;; Предусмотрен возврат к исходному состоянию при нажатии
;;; клавиши Esc или кнопки Undo
;;; Тестирована только в версии AutoCAD 2005
;;; Без обработчика ошибок
;;; Все права удалены, чувствуйте себя сбоводными
;;; для любых изменений кода
;;; Сохраните код в виде файла cbo.lsp в директории
;;; на путях файлов поддержки
;;; Возможный макрос для кнопки:
;;;
;;;^C^C^P(progn (terpri)(if (not C:CBO)(load "cbo"))(princ)(C:CBO))
;; начало кода
;; 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)))))))))
(defun BlockList  (dwg / blst bname)
  (vlax-for a  (vla-get-blocks dwg)
    (setq bname (vla-get-name a))
    (if    (and (equal :vlax-false (vla-get-isxref a))
         (equal :vlax-false (vla-get-islayout a))
         (not (wcmatch bname "_*,*$*,*|*"))
         (not (vl-string-search "*" bname)))
      (setq blst (cons bname blst))))
  (reverse blst))
(defun make-lib-dial  ()
  (setq fname (vl-filename-mktemp "libris.dcl"))
                    ; (setq fname (strcat (getvar
                    ; "dwgprefix")
                    ; "librys.dcl"))
  (setq fn (open fname "w"))
  (write-line "libres : dialog {" fn)
  (write-line
    (strcat "label = " "\"" "COPY BLOCK" "\"" ";")
    fn)
  (write-line ": boxed_column {" fn)
  (write-line
    (strcat "label = " "\"" "Select Block" "\"" ";")
    fn)
  (write-line ": list_box {" fn)
  (write-line (strcat "key = " "\"" "b_list" "\"" ";") fn)
  (write-line "width = 30; height = 20;}" fn)
  (write-line "}" fn)
  (write-line "spacer;" fn)
  (write-line "ok_cancel; " fn)
  (write-line "}" fn)
  (close fn))
                    ; ;
(defun set_list     (name lst)
  (start_list name)
  (mapcar 'add_list lst)
  (end_list))
                    ; ;
(defun run-lib-dial  (blk_lst)
  (setq dcl_ex (load_dialog fname))
  (new_dialog "libres" dcl_ex)
  (set_list "b_list" blk_lst)
  (action_tile
    "b_list"
    (strcat "(progn "
        "(setq b_name (nth (atoi $value) blk_lst)))"))
  (action_tile "accept" "(done_dialog 1)")
  (action_tile "cancel" "(done_dialog 0)")
  (setq knock (start_dialog))
  (unload_dialog dcl_ex)
  (done_dialog)
  (vl-file-delete fname)
  b_name)
;; main programm :
(defun C:CBO  (/ acapp acsp adoc blk_col blk_lst b_name    cert_blk fn
           fname ipt knock odbx x)
  (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 file to copy block from it" "" "dwg" 16))
  (if (setq fname (findfile fn))
    (progn
      (vla-open odbx fname)
      (setq blk_lst (BlockList odbx))
      (make-lib-dial)
      (setq b_name (run-lib-dial blk_lst))
      (if (= knock 1)
    (progn
      (setq blk_col (vla-get-blocks odbx))
      (if
        (not (vl-catch-all-error-p
           (vl-catch-all-apply
             (function
               (lambda () (vla-item blk_col b_name))))))
         (progn
           (setq cert_blk (vla-item blk_col b_name))
           (not
         (vl-catch-all-error-p
           (vl-catch-all-apply
             (function
               (lambda ()
             (vla-copyobjects
               odbx
               (vlax-safearray-fill
                 (vlax-make-safearray
                   vlax-vbobject
                   '(0 . 0))
                 (list (vla-item
                     (vla-get-blocks odbx)
                     b_name)))
               (vla-get-blocks adoc))))))))
         (princ "\Block Not Found")))))
    (princ "\File Not Found"))
  ;; check if desired block already in the current database:
  (if (not
    (vl-catch-all-error-p
      (vl-catch-all-apply
        (function
          (lambda () (vla-item (vla-get-blocks adoc) b_name))))))
    ;; insert block
    (progn (setq ipt (getpoint "\nSpecify insertion point: "))
       (vlax-invoke acsp 'InsertBlock ipt b_name 1 1 1 0))
    (alert "Problem with block copying"))
  (vlax-release-object odbx)
  (setq odbx nil)
  (mapcar (function
        (lambda (x)
          (vl-catch-all-apply
        (function (lambda () (vlax-release-object x))))))
      (list cert_blk blk_col))
  (vla-endundomark adoc)
  (gc)
  (gc)
  (princ))
                    ; ;
(princ
  "\n\t\t***\tType CBO to import block from other file ...\t***")
(princ)
;; окончание кода