插外部块INS_BLK 程序不能使用了

pxt2001 · 发表于 2014-1-16 22:06:07

以前在cad2004用的“插外部块INS_BLK”程序，在cad2008以上版本，不能用了，不知为何？
哪位热心人能修改下？

;;利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块
;;
;; INS_BLK.LSP
;;
;; 作者: 赖云龙(龙龙仔)
;;

luowy · 发表于 2014-1-17 14:26:32

给你个arx的插入外部参照的东西，一个07～09的，一个是2012的，
插入块的命令是sd，注意，该命令会自动搜寻cad支持工作目录下的所有块。务必先设置支持目录。
该命令执行了快1年多，无bug

pxt2001 · 发表于 2014-1-17 16:24:31

arx不能定制呀，不能修改程序

Lisp的乐趣就是，能自己动手，部分修改程序，diy成自己版本。

自贡黄明儒 · 发表于 2014-1-17 16:33:20

不能用了就直接用设计中心好

edata · 发表于 2014-1-19 16:50:25

;;利用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
)
(defun REGISTEROBJECTDBX (/ DBXSERVER) ;by Tony Tanzillo
(cond
((vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
)
((not (setq DBXSERVER (findfile "AxDb17.dll")))
(alert "Error: Can't locate ObjectDBX Library (AxDb17.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.17")
)
)
(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)

;;利用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 
   ) 
 
  (defun REGISTEROBJECTDBX (/ DBXSERVER) ;by Tony Tanzillo 
    (cond 
      ((vl-registry-read 
  "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID" 
       ) 
      ) 
      ((not (setq DBXSERVER (findfile "AxDb17.dll"))) 
       (alert "Error: Can't locate ObjectDBX Library (AxDb17.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.17") 
    ) 
  ) 
 
  (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)

pxt2001 · 发表于 2014-1-19 20:22:33

edata 发表于 2014-1-19 16:50

cad2008测试通过，明天再装上cad其他版本测试下。

明经到处有热心的高手，高手云集，敬佩！

pxt2001 · 发表于 2014-1-24 16:13:44

edata 发表于 2014-1-19 16:50

这个程序能在CAD2008使用，其他版本，不能用。

能否针对不同版本CAD，做一个通用的？

edata · 发表于 2014-1-24 17:34:30

pxt2001 发表于 2014-1-24 16:13
这个程序能在CAD2008使用，其他版本，不能用。

能否针对不同版本CAD，做一个通用的？

CAD2006、2013测试通过。

;;利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块
;;
;; INS_BLK.LSP
;;
;; 作者: 赖云龙(龙龙仔)
;;
;; E_MAIL: lai_wan_lung@pchome.com.tw
;;
;;
;; 本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:
;;
;; 1) 上列的版权通告必须出现在每一份拷贝里。
;; 2) 相关的说明文档也必须载有版权通告及本项许可通告。
;;
;; 本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
(vl-load-com)
(defun C:INS_BLK (/ DWGNAME NAME1 APP
DCL_FILE DCL_NAME DCL_FLAG BLK_LIST
OK_ID DCL_TOG
)
(defun REGISTEROBJECTDBX (/ DBXSERVER) ;by Tony Tanzillo
(cond
((vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
)
((not (setq DBXSERVER (findfile (strcat "AxDb"(substr (getvar "acadver") 1 2)".dll"))))
(alert (strcat "Error: Can't locate ObjectDBX Library (AxDb" (substr (getvar "acadver") 1 2) ".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 (strcat "ObjectDBX.AxDbDocument." (substr (getvar "acadver") 1 2)))
)
)
(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)

;;利用ObjectDbx技术在当前图形中插入其它未打开的图形中的图块 
;; 
;; INS_BLK.LSP 
;; 
;; 作者: 赖云龙(龙龙仔) 
;; 
;; E_MAIL: <a href="mailto:lai_wan_lung@pchome.com.tw">lai_wan_lung@pchome.com.tw</a> 
;; 
;; 版权所有 (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 
   ) 
 
  (defun REGISTEROBJECTDBX (/ DBXSERVER) ;by Tony Tanzillo 
    (cond 
      ((vl-registry-read 
  "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID" 
       ) 
      ) 
      ((not (setq DBXSERVER (findfile (strcat "AxDb"(substr (getvar "acadver") 1 2)".dll")))) 
       (alert (strcat "Error: Can't locate ObjectDBX Library (AxDb" (substr (getvar "acadver") 1 2) ".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 (strcat "ObjectDBX.AxDbDocument." (substr (getvar "acadver") 1 2))) 
    ) 
  ) 
 
  (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)

pxt2001 · 发表于 2014-1-28 12:47:06

edata 发表于 2014-1-24 17:34
CAD2006、2013测试通过。

多谢了！
我代表很多人，感谢你！

账号		自动登录	找回密码
密码			注册

[已解答] 插外部块INS_BLK 程序不能使用了

本帖子中包含更多资源

相关帖子

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

浏览过的版块