- 积分
- 2145
- 明经币
- 个
- 注册时间
- 2002-9-7
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2005-1-14 06:38:00
|
显示全部楼层
[Power=1](vl-load-com) (setvar "cmdecho" 0) (if (and (>= (atof (getvar "acadver")) 15.) (vlax-ldata-list "Ea_locked") (ssget "x" '((1 . "DWG Is Locked!"))) ) ;_ 结束and (progn (princ "\n图形加载中, 请稍候.......") (setq thisdocument (vlax-get-property (vlax-get-acad-object) 'activedocument) ) ;_ 结束setq (defun e:DelALL () (vlax-map-collection (vla-get-layers thisdocument ) ;_ 结束vla-get-layers '(lambda (x) (vla-put-lock x :vlax-false)) ) ;_ 结束vlax-map-collection (vlax-map-collection (vlax-get-property thisdocument 'modelspace ) ;_ 结束vlax-get-property '(lambda (x) (vla-delete x) ) ;_ 结束lambda ) ;_ 结束vlax-map-collection (vla-purgeall thisdocument) ;_ 结束vla-purgeall ) ;end defun ;;editor 反应器回调函数,执行删除实体 (defun DelAllObject (var1 var2) (e:delall) (vla-eval (vlax-get-acad-object) (strcat "MsgBox \"★ 版 权 所 有 ★\"" ", " "vbExclamation+vbSystemModal" ", " "\"作者: Eachy\"" ) ) (princ) ) ;_ 结束defun ;;main (vl-cmdf ".undo" "a" "off") (vl-cmdf ".undo" "c" "N") (mapcar '(lambda (x) (vl-cmdf ".undefine" x)) '("U" "Wblock" "Qsave" "save" "NEW") ) ;_ 结束mapcar ;;清理环境 (if (and (= (getvar "sdi") 0) (> (vla-get-count (vlax-get-property (vlax-get-acad-object) 'documents) ) 1 ) ) (progn (vlax-for item (vlax-get-property (vlax-get-acad-object) 'documents ) (if (/= (vla-get-name item) (getvar "dwgname")) (vla-close item :vlax-true (vla-get-name item)) ) ) (vla-eval (vlax-get-acad-object) (strcat "MsgBox \"★ 版 权 所 有 ★\"" ", " "vbExclamation+vbSystemModal" ", " "\"作者: Eachy\"" ) ) ) ) (vlax-map-collection (vla-get-layers thisdocument) '(lambda (x) (vla-put-lock x :vlax-false)) ) ;;删除标记 (vl-cmdf ".erase" (ssget "x" '((1 . "DWG Is Locked!"))) "") ;;准备还原 (setq count (sslength (ssget "x")) l count an 0. ) ;_ 结束setq (while (> count 0) (grtext -2 (strcat "已完成 " (rtos (/ (* 100.0 (- l count)) l) 2 0 ) "%...." ) ) (setq obj (vla-item (vlax-get-property thisdocument 'modelspace ) ;_ 结束vlax-get-property (setq count (1- count)) ) ;_ 结束vla-item ) ;_ 结束setq (vla-move obj (vlax-3d-point '(0. 0. 0.)) (vlax-3d-point (polar '(0. 0. 0.) (setq an (+ an (/ pi 80))) (- (- (* (float count) (float count)) (* (1- (float count)) 2) ) ;_ 结束- ) ;_ 结束- ) ;_ 结束polar ) ;_ 结束vlax-3d-point ) ;end vla-move (vla-put-visible obj :vlax-true) ) ;end while (vla-zoomextents (vla-get-application (vlax-get-acad-object))) (setq count nil an nil l nil obj nil ) ;;还原结束清理变量 ;;锁定全部图层 (vlax-map-collection (vla-get-layers thisdocument) '(lambda (x) (vla-put-lock x :vlax-true)) ) ;_ 结束vlax-map-collection ;;反应器部分 ;;文档反应器,禁止新建,测试中可能不稳定 (if (not myDocReactor) (setq myDocReactor (vlr-docmanager-reactor nil '((:vlr-documentcreated . sDelAllObject)) ) ;_ 结束vlr-docmanager-reactor ) ;_ 结束setq ) ;_ 结束vlr-docmanager-reactor ;;文档反应器回调,删除加密图形中的实体 (defun sDelAllObject (var1 var2) ;;解锁图层 (vlax-map-collection (vla-get-layers thisdocument ) ;_ 结束vla-get-layers '(lambda (x) (vla-put-lock x :vlax-false)) ) ;_ 结束vlax-map-collection (vlax-map-collection (vlax-get-property thisdocument 'modelspace ) ;_ 结束vlax-get-property '(lambda (x) (vla-delete x) ) ;_ 结束lambda ) ;_ 结束vlax-map-collection (vla-purgeall thisdocument) ) ;_ 结束defun ;;禁止 Wblock 方法 (vlr-wblock-reactor nil '((:VLR-wblockNotice . DelAllObject)) ) ;_ 结束vlr-wblock-reactor ;;数据库反应器,禁止新加及修改,包括 VBA 方法 (vlr-acdb-reactor "Ea-acdb-reactor" '((:vlr-objectModified . SaveChangedLyr) ;修改 (:vlr-objectAppended . SaveChangedLyr) ;添加 ) ) ;_ 结束vlr-acdb-reactor ;;禁止 ARX 深度克隆 (vlr-deepclone-reactor nil '((:vlr-begindeepclone . DelAllObject)) ) ;_ 结束vlr-deepclone-reactor ;;编辑器反应器 (vlr-editor-reactor nil '((:vlr-beginDxfOut . DelAllObject) ;禁止dxfout (:vlr-beginSave . DelAllObject) ;禁止保存 (:vlr-lispWillStart . DelAllObject) ;防止Lisp输出 (:vlr-commandwillstart . ESCcommand) (:vlr-commandended . DelAllNew) ;禁止在图形内绘制 (:vlr-commandcancelled . DelAllNew) ;命令中断时检查是否有新实体 (:vlr-lispEnded . DelAllNew) ;检查Lisp生成的新实体 (:vlr-lispCancelled . DelAllNew) ;中断后是否有新实体 (:vlr-sysvarchanged . myResetSysvar) ;防止修改 savetime ) ) ;_ 结束vlr-editor-reactor ;;Command 开始时执行 ESC,经测试不能屏蔽 VBAIDE Vlide Ctrl+P (defun ESCCommand (var1 var2 /) (if (or (not (wcmatch (strcase (vl-princ-to-string (car var2))) "*ZOOM,*PAN,*QUIT,*EXIT,*CLOSE" ) ;_ 结束wcmatch ) ;_ 结束not (wcmatch (strcase (vl-princ-to-string (car var2))) "*PLOT") ) ;_ 结束or (progn (vla-eval (vlax-get-acad-object) (strcat "Sendkeys \"{ESC}\"") ) ;发送 中断命令 (vla-eval (vlax-get-acad-object) (strcat "Sendkeys \"{ESC}\"") ) ) ;_ 结束if (princ) ) ;_ 结束if ) ;_ 结束defun ;;设置自动保存时间 (defun myResetSysvar (var1 var2) (if (/= (vlax-variant-value (vla-GetVariable thisdocument "savetime" ) ;_ 结束vla-GetVariable ) ;_ 结束vlax-variant-value 600 ) ;_ 结束/= (vla-setvariable thisdocument "savetime" 600 ) ;_ 结束vla-setvariable ) ;_ 结束if ) ;_ 结束defun ;;删除所有新生成的 Mspace 空间实体 (defun DelAllNew (var1 var2 / lyrs lyrlst item) (setq lyrs (vla-get-layers thisdocument ) ;_ 结束vla-get-layers ) ;_ 结束setq (if HasChangedObject (progn (mapcar '(lambda (item / name lyr lyrobj) (IF (not (vlax-erased-p item)) (progn (setq name (strcase (vla-get-objectname item)) ) ;_ 结束setq (if (vl-position name '("ACDB3DFACE" "ACDB3DPOLYLINE" "ACDB3DSOLID" "ACDBARC" "ACDBATTRIBUTE" "ACDBATTRIBUTEDEFINITION" "ACDBBLOCKREFERENCE" "ACDBCIRCLE" "ACDB3POINTANGULAR" "ACDBALIGNED" "ACDBANGULAR" "ACDBROTATED" "ACDBELLIPSE" "ACDBERNALREFERENCE" "ACDBHATCH" "ACDBLEADER" "ACDBPOLYLINE" "ACDBLINE" "ACDBMINSERTBLOCK" "ACDBMLINE" "ACDBMTEXT" "ACDBPOINT" "ACDBPOLYFACEMESH" "ACDBPOLYGONMESH" "ACDBPVIEWPORT" "ACDBRASTER" "ACDBREGION" "ACDBSHAPE" "ACDBSOLID" "ACDBSPINE" "ACDBTABLE" "ACDBTEXT" "ACDB2DPOLYLINE" "ACDBTOLERANCE" ) ) ;_ 结束vl-position (progn (setq lyr (vla-get-layer item)) (if (= (vla-get-lock (setq lyrobj (vla-item lyrs lyr)) ) ;_ 结束vla-get-lock :vlax-true ) ;_ 结束= (vla-put-lock lyrobj :vlax-false) ) ;_ 结束if (vla-delete item) ) ;_ 结束progn ) ;_ 结束if ) ;_ 结束progn ) ;_ 结束IF ) ;_ 结束lambda (vl-remove nil (mapcar 'vlax-ename->vla-object HasChangedObject ) ;_ 结束mapcar ) ;_ 结束vl-remove ) ;_ 结束mapcar (setq HasChangedObject nil) ) ;_ 结束progn ) ;_ 结束if (vlax-map-collection (vla-get-layers thisdocument) ;_ 结束vla-get-layers '(lambda (x) (vla-put-lock x :vlax-true)) ) ;_ 结束vlax-map-collection ) ;_ 结束defun ;;acdb 回调函数, 保存修改或者新加的实体 (defun SaveChangedlyr (var1 var2 /) (if (not HasChangedObject) (setq HasChangedObject (list (cadr var2))) (setq HasChangedObject (append (list (cadr var2)) HasChangedObject) ) ;_ 结束setq ) ;_ 结束if ) ;end defun ) ;end progn (progn (vlr-remove-all) (setq myEditorReactor nil myEditwblockreactor nil myAcdbReactor nil thisdocument nil myDeepclonereactor nil HasChangedObject NIL ) ;end setq ) ;end progn ) ;_ 结束if (princ)
[/Power] |
评分
-
参与人数 1 | 威望 +1 |
金钱 +4 |
贡献 +4 |
激情 +4 |
收起
理由
|
龙龙仔
| + 1 |
+ 4 |
+ 4 |
+ 4 |
【好评】好程序 |
查看全部评分
|