恳请版主对该函数 MergeLayers 进行更新升级!!!

jaminth

恳请版主对该函数进行更新升级!!!
该函数对图中的块不起作用!如果要合并的图层处在块中,特别是处在属性块中!程序运行时会出现这样的提示:"; 错误: 参数类型错误: stringp nil"
该函数来源于以下链接:
http://www.mjtd.com/Functions/ArticleShow.asp?ArticleID=1193

2. ;; Usage: (MergeLayers "Layer1" "Layer2")
3. (defun MergeLayers (lay1 lay2 / cnt space blocks attrs)
4.   (command "-layer" "u" lay1 "")
5.   (setq blocks (vla-get-blocks
6.    (vla-get-activedocument (vlax-get-acad-object))
7.         )
8.   )
9.   (setq cnt 0)
10.   (while (< cnt (vla-get-count blocks))
11.     (setq space (vla-item blocks cnt))
12.     (vlax-for itm space
13.       (if (= (strcase (vla-get-layer itm)) (strcase lay1))
14. (vla-put-layer itm lay2)
15.       )
16.       (if (and (= (vla-get-ObjectName itm) "AcDbBlockReference")
17.         (= (vla-get-HasAttributes itm) :vlax-true)
18.    )
19. (progn
20.    (setq attrs (vlax-safearray->list
21.    (vlax-variant-value (vla-getattributes itm))
22.         )
23.    )
24.    (foreach attr attrs
25.      (if (= (strcase (vla-get-layer attr)) (strcase lay1))
26.        (vla-put-layer attr lay2)
27.      )
28.    )
29. )
30.       )
31.     )
32.     (setq cnt (1+ cnt))
33.   )
34.   (if (= (getvar "CLAYER") lay1)
35.     (setvar "CLAYER" lay2)
36.   )
37.   (command "_.purge" "lay" lay1 "_n")
38. ;;;  (command "_.regenall")
39.   (princ)
40. )

;; Usage: (MergeLayers "Layer1" "Layer2") (defun MergeLayers (lay1 lay2 / cnt space blocks attrs)   (command "-layer" "u" lay1 "")   (setq blocks (vla-get-blocks    (vla-get-activedocument (vlax-get-acad-object))         )   )   (setq cnt 0)   (while (< cnt (vla-get-count blocks))     (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)    ) (progn    (setq attrs (vlax-safearray->list    (vlax-variant-value (vla-getattributes itm))         )    )    (foreach attr attrs      (if (= (strcase (vla-get-layer attr)) (strcase lay1))        (vla-put-layer attr lay2)      )    ) )       )     )     (setq cnt (1+ cnt))   )   (if (= (getvar "CLAYER") lay1)     (setvar "CLAYER" lay2)   )   (command "_.purge" "lay" lay1 "_n") ;;;  (command "_.regenall")   (princ) )

7686599

可以试试遍历块内对象。

龙龙仔

到下列

http://free.ys168.com/?eachy

找LYRTV23.RAR

jaminth

龙龙仔,能不能提供原码?!

龙龙仔

Eachy提供出來給網友使用就很好了,這個程序是很難寫的!