;;利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块
;;
;; INS_BLK.LSP
;;
;; 作者: 赖云龙(龙龙仔)
;;
;; E_MAIL: lai_wan_lung@pchome.com.tw
;;
;; 版权所有 (C) 2003
;;
;;   本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:
;;
;;   1)  上列的版权通告必须出现在每一份拷贝里。
;;   2)  相关的说明文档也必须载有版权通告及本项许可通告。
;;
;;   本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;;   用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
(vl-load-com)
(defun C:INS_BLK (/	       dwgname	    name1	 app
		  dcl_file     dcl_name	    dcl_flag	 blk_list
		  ok_id	       dcl_tog	    blk_list	 dbxblocks
		  dbxdoc       doc	    dwgname	 name1
		  FILL_BLK_NAME		    DWG_SEL
		  REGISTEROBJECTDBX
		 )
  (defun REGISTEROBJECTDBX (/ DBXSERVER) ;by Tony Tanzillo 
    (cond
      ((vl-registry-read
	 "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
       )
      )
      ((not (setq DBXSERVER (findfile "AxDb15.dll")))
       (alert "Error: Can't locate ObjectDBX Library (AxDb15.dll)")
      )
      (t
       (startapp "regsvr32.exe" (strcat "/s \"" DBXSERVER "\""))
       (or
	 (vl-registry-read
	   "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
	 )
	 (alert
	   "Error: Failed to register ObjectDBX ActiveX services."
	 )
       )
      )
    )
  )

  (defun INS (ENT / SB)
    (if	(/= "" DWGNAME)
      (progn
	(prompt	(strcat	"\n从图档"
			DWGNAME
			"插入图块"
			(getvar "insname")
			"\n"
		)
	)
	(setq SB (vla-item DBXBLOCKS ENT))
	(vla-copyobjects
	  DBXDOC
	  (vlax-safearray-fill
	    (vlax-make-safearray
	      vlax-vbobject
	      '(0 . 0)
	    )
	    (list SB)
	  )
	  (vla-get-modelspace DOC)
	)
	(vlax-release-object SB)
      )
      (prompt
	(strcat "\n从图档" NAME1 "插入图块" (getvar "insname") "\n")
      )
    )
    (command "_.INSERT" "")
  )

  (defun DWG_SEL (FLAG / STR1 STR2 BLK BLK_NO BLK_NO_TEXT)

    (if	(= FLAG 1)
      (setq DBXBLOCKS (vla-get-blocks DOC))
      (progn
	(setq
	  DWGNAME (getfiled "选取图档" (getvar "dwgprefix") "dwg" 8)
	)
	(if (equal (strcase NAME1) (strcase DWGNAME))
	  (setq	DBXBLOCKS (vla-get-blocks DOC)
		DWGNAME	  ""
	  )
	  (progn
	    (vla-open DBXDOC DWGNAME)
	    (setq DBXBLOCKS (vla-get-blocks DBXDOC))
	  )
	)
      )
    )
    (setq BLK_LIST '())
    (vlax-for BLK DBXBLOCKS
      (if (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))
	       (= (vla-get-isxref BLK) :vlax-false)
	  )
	(setq BLK_LIST
	       (append BLK_LIST (list (vla-get-name BLK)))
	)
      )
    )

    (if	(/= BLK_LIST '())
      (setq BLK_LIST (acad_strlsort BLK_LIST))
    )
    (start_list "dcl_blk_list")
    (mapcar 'add_list BLK_LIST)
    (end_list)

    (setq BLK_NO (length BLK_LIST))
    (setq BLK_NO_TEXT
	   (strcat "图档中的图块\n 共计  "
		   (itoa BLK_NO)
		   "  个"
	   )
    )
    (set_tile "dcl_blk_no" BLK_NO_TEXT)
    (set_tile "dcl_blk_list" "0")
    (FILL_BLK_NAME)

    (if	(/= "" DWGNAME)
      (set_tile	"txt_2"
		(if (< (strlen DWGNAME) 90)
		  (progn
		    (setq STR1 (substr DWGNAME 1 44)
			  STR2 (substr DWGNAME 45)
		    )
		    (strcat STR1 "\n" STR2)
		  )
		  (progn
		    (setq STR1 (substr DWGNAME 1 40)
			  STR2 (vl-filename-base
				 (strcase (strcat DWGNAME
						  (vl-filename-extension DWGNAME)
					  )
				 )
			       )
		    )
		    (strcat STR1 "....\n...." STR2)
		  )
		)
      )
      (set_tile	"txt_2"
		(if (< (strlen NAME1) 90)
		  (progn
		    (setq STR1 (substr NAME1 1 44)
			  STR2 (substr NAME1 45)
		    )
		    (strcat STR1 "\n" STR2)
		  )
		  (progn
		    (setq STR1 (substr NAME1 1 44)
			  STR2 (vl-filename-base
				 (strcase (strcat NAME1
						  (vl-filename-extension NAME1)
					  )
				 )
			       )
		    )
		    (strcat STR1 "\n...." STR2)
		  )
		)
      )
    )
  )

  (defun FILL_BLK_NAME (/ BLK_ID FILL_NAME)
    (setq BLK_ID (get_tile "dcl_blk_list"))
    (setq BLK_ID (atoi BLK_ID))
    (if	(/= BLK_LIST '())
      (progn
	(setq FILL_NAME (nth BLK_ID BLK_LIST))
	(setvar "insname" FILL_NAME)
	(set_tile "dcl_blk_name" FILL_NAME)
      )
      (progn
	(setvar "insname" "")
	(set_tile "dcl_blk_name" "")
      )
    )
  )

  (setq NAME1 (strcat (getvar "dwgprefix") (getvar "dwgname")))
  (setq DWGNAME "")
  (setq APP (vlax-get-acad-object))
  (setq DOC (vla-get-activedocument APP))
  (if (= "15" (substr (getvar "acadver") 1 2))
    (progn
      (if (not (REGISTEROBJECTDBX))
	(exit)
      )
      (setq
	DBXDOC (vla-getinterfaceobject APP "ObjectDBX.AxDbDocument")
      )
    )
    (setq
      DBXDOC (vla-getinterfaceobject APP "ObjectDBX.AxDbDocument.16")
    )
  )

  (setq	DCL_FILE "ins_blk"
	DCL_NAME "blk_1"
  )
  (setq DCL_FLAG (load_dialog DCL_FILE))
  (if (< DCL_FLAG 0)
    (exit)
  )
  (if (not (new_dialog DCL_NAME DCL_FLAG))
    (exit)
  )

  (DWG_SEL 1)
  (set_tile "dcl_blk_list" "0")
  (FILL_BLK_NAME)

  (action_tile "key_insert" "(dwg_sel 0)")
  (action_tile "cancel" "(done_dialog 0)")
  (action_tile
    "accept"
    "(done_dialog 1)"
  )
  (setq OK_ID (start_dialog))
  (unload_dialog DCL_FLAG)
  (if (and (= 1 OK_ID) (/= "" (getvar "insname")))
    (INS (getvar "insname"))
  )
  (vlax-release-object APP)
  (vlax-release-object DOC)
  (vlax-release-object DBXDOC)
  (vlax-release-object DBXBLOCKS)
  (setq	DBXDOC NIL
	DBXBLOCKS NIL
	DOC NIL
  )
  (princ)
)
(prompt "\nType INS_BLK")
(princ)
