[求助]：不炸开块参照，图元改图层改进

lennie

以前网上收集的一个程序，现在想做以下两点改进。因为没学过lisp，所以只能到这里劳烦一下大虾了。
1、能一次性选择多个图元
2、图元被选择后，图元能够虚显

2. (defun c:ch ()
   
3. (vl-load-com)
   
4. (setq obj (car (nentsel "\n请选择块内的一个图元: ")))
   
5. (setq obj (vlax-ename->vla-object obj))
   
6. (setq col (getstring "\n请输入颜色号(1~255): "))
   
7. (vlax-put-property obj 'color col)
   
8. (setq lay (getstring "\n请输入图层名称(已存在的): "))
   
9. (vla-put-layer obj lay)
   
10. (vl-cmdf "regen")
    
11. (princ)
    
12. )
    

(defun c:ch ()<br /> (vl-load-com)<br /> (setq obj (car (nentsel "\n请选择块内的一个图元: ")))<br /> (setq obj (vlax-ename->vla-object obj))<br /> (setq col (getstring "\n请输入颜色号(1~255): "))<br /> (vlax-put-property obj 'color col)<br /> (setq lay (getstring "\n请输入图层名称(已存在的): "))<br /> (vla-put-layer obj lay) <br /> (vl-cmdf "regen")<br /> (princ)<br /> )<br />

21247sugar

谢谢楼主分享

meiy801226

好东西

最爱小蝎

怎么个意思，不太明白！

ajing_sky

(defun c:ch ()
  (vl-load-com)
  (setq ss (ssadd))
  (while
    (setq ent (car (nentsel)))
     (redraw ent 3)
    (setq ss (ssadd ent ss))
    )
  (setq i 0)
  (setq col (getstring "\n请输入颜色号(1~255): "))
  (setq lay (getstring "\n请输入图层名称(已存在的): "))
  (repeat (sslength ss)
    (setq obj (vlax-ename->vla-object (ssname ss i)))
    (vlax-put-property obj 'color col)
    (vla-put-layer obj lay)
    (setq i (1+ i))
  )
  (vl-cmdf "regen")
  (princ)
)

程序如上,基本可以满足楼主的需要..

434939575

感谢，太好了！