（完成）[编程申请]：自动转到别的图层

wcf · 发表于 2004-9-20 12:02:11

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

申请高手编一个程序解决下述问题：
　　1.设定好一个特殊图层，用来显示每次编辑图的变化。每次修改图时，所有改动能自动转到此图层上，这样就能知道此次修改的所有内容。
　　2.每次改动包括图上的各种操作。
　　3.适用于各种版本的CAD

eachy · 发表于 2004-9-20 12:09:11

最初由 wcf 发布
[B]申请高手编一个程序解决下述问题：
　　1.设定好一个特殊图层，用来显示每次编辑图的变化。每次修改图时，所有改动能自动转到此图层上，这样就能知道此次修改的所有内容。
　　2.每次改动包括图上的各种操作。
　... [/B]

你所说的功能不可能一个文件适用所有CAD版本。

wcf · 发表于 2004-9-20 14:44:43

分别编也可以，肯定是有一定的难度，比如原来的“TEXT”图层的文字“aa”，现在编辑成“bb”以后，要求自动转到先建立的“TEXT1”图层，或所指定的某个图层且颜色随层。或原图上一条线加长以后，也能自动转到此图层上，且颜色随层，这样所做编辑工作一目了然，便于修改。

eachy · 发表于 2004-9-22 12:25:02

最初由 wcf 发布
[B]分别编也可以，肯定是有一定的难度，比如原来的“TEXT”图层的文字“aa”，现在编辑成“bb”以后，要求自动转到先建立的“TEXT1”图层，或所指定的某个图层且颜色随层。或原图上一条线加长以后，也能自动转到此图层?.. [/B]

;|
程序简介：用于修改图形时将修改的实体或者新生成的实体转换至指定图层
适用AutoCAD2000+以上版本。
免责声明：本程序仅提供作为应用上的参考, 而未声明或隐含任何保证;
对于任何特殊用途之适应性, 以及商业销售所隐含作出的保证,
在此一概予以否认。
拒绝担保：拒绝任何责任担保，因使用该程序所致的全部风险及后果均由用
户自己承担。
作者：eahcy[晓东家园 [url]www.xdcad.net[/url]]
复制、传播请保持以上信息完整
|;
(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已启用修改自动更新图层功能!")

;| 
程序简介：用于修改图形时将修改的实体或者新生成的实体转换至指定图层 
          适用AutoCAD2000+以上版本。 
                                                                   
免责声明：本程序仅提供作为应用上的参考, 而未声明或隐含任何保证;    
                                                                   
           对于任何特殊用途之适应性, 以及商业销售所隐含作出的保证, 
                                                                   
           在此一概予以否认。                                     
                                                                   
拒绝担保：拒绝任何责任担保，因使用该程序所致的全部风险及后果均由用 
          户自己承担。                                             
                                                                   
作    者：eahcy[晓东家园 [url]www.xdcad.net[/url]]                            
                                                                   
          复制、传播请保持以上信息完整                            
|; 
(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已启用修改自动更新图层功能!")

附件为改进版 For 2000+

wcf · 发表于 2004-10-3 21:40:30

很不错，可惜有一批R14的用户无法使用。谢谢eahcy版主！

eachy · 发表于 2004-11-7 23:52:27

最初由 wcf 发布
[B]很不错，可惜有一批R14的用户无法使用。谢谢eahcy版主！ [/B]

For R14

wcf · 发表于 2004-11-9 16:46:02

谢谢eachy版主的热诚!
请问用appload加载后需要输入什么命令才能操作？

eachy · 发表于 2004-11-9 18:20:52

最初由 wcf 发布
[B]谢谢eachy版主的热诚!
请问用appload加载后需要输入什么命令才能操作？ [/B]

加载后不需要启动命令，自动转换的。
取消自动转换 Removelyr，重新启用自动图层Resetlyr

liuyj · 发表于 2004-11-9 18:45:49

小心啊，上次我用了一下，结果存盘的时候状如死机，等了好半天才存上，吓得我再也不敢用了。

eachy · 发表于 2004-11-9 20:08:12

最初由 liuyj 发布
[B]小心啊，上次我用了一下，结果存盘的时候状如死机，等了好半天才存上，吓得我再也不敢用了。 [/B]

你用了哪个版本？

wcf · 发表于 2004-11-9 21:03:34

我记得在2002版本下加载程序后，正常应该在命令行出现“设置一个图层”，然后所有的操作自动转到所设定的图层。
但是在R14下加载程序后在命令行没有反应，且不能转换图层，不知是何原因？
烦版主在调试一下。

eachy · 发表于 2004-11-10 00:07:30

最初由 wcf 发布
[B]我记得在2002版本下加载程序后，正常应该在命令行出现“设置一个图层”，然后所有的操作自动转到所设定的图层。
但是在R14下加载程序后在命令行没有反应，且不能转换图层，不知是何原因？
烦版主在调试一?.. [/B]

重新下载附件

wcf · 发表于 2004-11-10 11:48:22

这次能用了，但还存在一个小问题
用DTEXT命令输入文字不能自动转到所建立的图层上
copy标注尺寸时死机

liuyj · 发表于 2004-11-10 11:53:23

最初由 eachy 发布
[B]
你用了哪个版本？ [/B]

for 2002的版本

zhangrenku · 发表于 2004-11-10 15:26:55

这个东西对画图有很大用处吗？我试了一下，不知道对做图有什么方便。

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

（完成）[编程申请]：自动转到别的图层

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [编程申请]：自动转到别的图层