图层合并lisp，有点毛病，求高人指教！
我仿造网上的一个高人的合并图层lisp程序自己写的另一个版本，可是还是有些图纸的图层不能被合并，不知为何？原来那个高人的图层合并程序也有点毛病，如果是嵌套块，图层不能被合并，所以我修改了一下，稍微改善了一点，但是对于有些图形文件，仍然不能正常工作，求高人指教，下面是代码：
(defun c:mlay ()
(setq lay1 (getstring "\n请输入要合并的图层:")
lay2 (getstring "\n请输入要保留的图层:")
)
(MergeLayers lay1 lay2)
)
;; Usage: (MergeLayers "Layer1" "Layer2")
(defun MergeLayers (lay1 lay2 / i block countOfBlock1)
(command "-layer" "u" lay1 "")
(setq block (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq i 0
countOfBlock1
(vla-get-count block)
)
(while (< i countOfBlock1)
(changeLayer block)
(setq i (1+ i)
)
)
(if (= (getvar "CLAYER") lay1)
(setvar "CLAYER" lay2)
)
(command "_.purge" "lay" lay1 "_n")
(princ)
)
(defun changeLayer (blocks / cnt space countOfBlock2)
;;;(setq cnt 0
;;; countOfBlock2
;;;(vla-get-count blocks);;;某些时候这句代码会出错，说vla-get-count不能用于blocks对象，不知为何？
;;;)
;;;
;;;(setq errobj (vl-catch-all-apply (vla-get-count blocks)))
;;;(if (vl-catch-all-error-p errobj)
;;; (setq cnt (1+ cnt))
;;; (exit)
;;;)
(setq cnt 0
countOfBlock2
(vla-get-count blocks)
)
(while (< cnt countOfBlock2)
(setq space (vla-item blocks cnt))
(vlax-for itm space
(if (= (strcase (vla-get-layer itm)) (strcase lay1))
(vla-put-layer itm lay2)
)
;;;如果是块，递归下去
(if (and (= (vla-get-ObjectName itm) "AcDbBlockReference")
(= (vla-get-HasAttributes itm) :vlax-true)
)
(changeLayer itm)
)
)
(setq cnt (1+ cnt))
)
)
本帖最后由 xjf 于 2012-9-5 21:05 编辑
最终找到了G版的大作,可以缓口气了
喝水不忘挖井人
以下是链接,
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=93053
(defun KK(O_Lay D_Lay)
(command "_.change" (ssget "x" (list (cons 8 O_Lay))) "" "p" "la" D_Lay "")
(command "_.purge" "la" O_Lay "n")
)
页:
[1]