;|
程序简介：用于修改图形时将修改的实体或者新生成的实体转换至指定图层
          适用AutoCAD2000+以上版本。
                                                                  
免责声明：本程序仅提供作为应用上的参考, 而未声明或隐含任何保证;   
                                                                  
           对于任何特殊用途之适应性, 以及商业销售所隐含作出的保证,
                                                                  
           在此一概予以否认。                                     
                                                                  
拒绝担保：拒绝任何责任担保，因使用该程序所致的全部风险及后果均由用
          户自己承担。                                            
                                                                  
作    者：eahcy[晓东家园 www.xdcad.net]      	2004年09月22日                      
                                                                  
          复制、传播请保持以上信息完整                            
|;
(vl-load-com)
;;数据库监视器
(if (not ea:savenew)
  (setq	ea:savenew
	 (vlr-acdb-reactor
	   "Ea-acdb-reactor"
	   '((:vlr-objectModified . SaveChangedLyr) ;修改
	     (:vlr-objectAppended . SaveChangedLyr) ;添加
	    )
	 )
  )
)
;;命令监视器
(if (not ea:chgnew)
  (setq	ea:chgnew
	 (vlr-editor-reactor
	   nil
	   '((:vlr-commandended . ChgModefied) ;图形内绘制
	     (:vlr-commandcancelled . ChgModefied)
					;命令中断时检查是否有新实体
	     (:vlr-lispEnded . ChgModefied) ;检查Lisp生成的新实体
	     (:vlr-lispCancelled . ChgModefied) ;中断后是否有新实体
	    )
	 )
  )
)
;;命令回调
(defun ChgModefied (var1 var2 / lyrs lyrlst item doc)
  (setq	lyrs (vla-get-layers
	       (setq doc (vla-get-activedocument (vlax-get-acad-object)))
	     ) ;_vla-get-layers
  ) ;_setq
  (if HasChangedObject
    (progn
      (vla-startundomark doc)
      (mapcar
	'(lambda (item / name lyr lyrobj)
	   (IF (and (not (vlax-erased-p item))
		    (= (type ea:globlelay) 'STR)
		    (vlax-property-available-p item 'layer)
		    (not (vl-catch-all-error-p
			   (vl-catch-all-apply
			     'vla-item
			     (list lyrs ea:globlelay)
			   )
			 )
		    )
		    (/=	(strcase (vla-get-layer item))
			(strcase ea:globlelay)
		    )
	       );_ end and
	     (progn
	       
	       (if (= (vla-get-lock
			(setq lyrobj
			       (vla-item lyrs
					 (setq lyr (vla-get-layer item))
			       )
			)
		      ) ;_ vla-get-lock
		      :vlax-true
		   ) ;_ =
		 (vla-put-lock lyrobj :vlax-false)
	       ) ;_ if
	       (vla-put-layer item ea:globlelay) ;change layer
	       (vla-put-color item 256)	;change color to bylayer
	     ) ;_ progn
	   ) ;_ if
	 ) ;_ lambda
	(vl-remove nil
		   (mapcar 'vlax-ename->vla-object
			   HasChangedObject
		   ) ;_ mapcar
	) ;_ vl-remove
      ) ;_ mapcar
      (vla-endundomark doc)
      (setq HasChangedObject nil)
    ) ;_ progn
  ) ;_ if
)
;;acdb 回调函数, 保存修改或者新加的实体
(defun SaveChangedlyr (var1 var2 /)
  (if (not HasChangedObject)
    (setq HasChangedObject (list (cadr var2)))
    (setq HasChangedObject
	   (append (list (cadr var2)) HasChangedObject)
    ) ;_ setq
  ) ;_ if
) ;_ end defun
;;设置修改的图层，使用前请先设定要修改的图层
(defun c:setlyr	(/ str lyr)
  (if (setq str (getstring "\n输入转换至图层: "))
    (progn
      (if (not (tblsearch "layer" str))
	(progn
	  (setq	lyr
		 (vla-add (vla-get-layers
			    (vla-get-activedocument (vlax-get-acad-object))
			  )
			  str
		 )
	  )
	  (vla-put-color lyr 6) ;_可以通过图层管理器修改颜色
	)
      )
      (setq ea:globlelay str)
    )
  )
  (princ)
)
(defun c:Removelyr (/)
  (vlr-remove-all)
  (setq	ea:savenew
	 nil
	ea:chgnew nil
  )
  (princ "\n\t已取消自动更新图层, 要启用请重新加载本程序!")
  (princ)
)
(princ "\n\t已启用修改自动更新图层功能!")