找到lyy在2003年写的程序，现在有没有更简洁的写法（有关反应器）

artken

下面这段是lyy在2003年发的程序，在CAD2008里测试是可以用的，只是图块是程序画的，不能用自己的属性块。其实执行过程中是不没必要跳出那个让人填写的EVEV属性值的对话框的，写了也没用，点“确定”后值也是会自动变成程序测量的数值，好像多此一举（还是我还没测出其它方面用处？）。
另外就是被参照的基准点不能移动，有没办法实现参照点也可以移动？也就是移动这个基准点（可以是直线的一端点或块的插入点）时其它参照它的标高值也能自动跟着变？
不知5年后的今天有没有更简洁的写法？

2. ;; ;;立面标高关联程序 ;;
3. (vl-load-com) ;;标高反应器
4. (defun elev-record(owner-object reactor-object parameter-list)
5.   (if (not (vlax-erased-p owner-object))
6. (setq elev-to-update (append elev-to-update (list owner-object))) ) )
7. (defun elev-copied(owner-object reactor-object parameter-list / new-ename)
8. (setq elev-object-reactor reactor-object) (setq new-ename (car parameter-list))
9. (setq elev-to-update (append elev-to-update (list new-ename))) )
10. (defun commande (calling-reactor lst / elev-update-attr elev-object)
11. (defun elev-update-attr(elev-object / elev-ename insp text attr-object)
12. (setq elev-ename (vlax-vla-object->ename elev-object))
13. (setq insp (vla-get-InsertionPoint elev-object))
14.   (setq insp (vlax-safearray->list (vlax-variant-value insp)))
15. (setq text (rtos (/ (+ (cadr insp) (vlax-ldata-get "yad_dict" "elev")) 1000.0) 2 3))
16. (if (= text "0.000") (setq text "%%p0.000"))
17. (setq attr-object (vlax-ename->vla-object (entnext elev-ename))) (vla-put-textstring attr-object text)
18.   (if (vlax-object-released-p attr-object) (vlax-release-object attr-object) ) )
19. (if elev-to-update (progn (setq elev-to-update (vl-remove nil elev-to-update)) (foreach elev-object elev-to-update (if (= (type elev-object) 'ename) (progn (setq elev-object (vlax-ename->vla-object elev-object)) (vlr-owner-add elev-object-reactor elev-object) ) ) (if (vlax-erased-p elev-object) nil (elev-update-attr elev-object) ) (if (vlax-object-released-p elev-object) (vlax-release-object elev-object) ) ) (setq elev-to-update nil) ) ) (princ) ) (vlr-command-reactor nil '((:vlr-commandEnded . commande)))
20.   ;;如果要确保图形下次打开时关联有效，请把以上代码及本段代码加入acad2000doc.lsp文件。
21. ;;(if (and (vlax-ldata-get "yad_dict" "elev")
22. ;; (setq ss (ssget "x" '((0 . "insert")(2 . "yad_elev"))))
23. ;; ) ;; (progn ;; (setq n -1)
24. ;; (repeat (sslength ss)
25. ;; (setq ent (ssname ss (setq n (1+ n))))
26. ;; (setq ent (vlax-ename->vla-object ent))
27. ;; (setq l_obj (append l_obj (list ent)))
28. ;; )
29. ;; (setq elev-object-reactor
30. ;; (vlr-object-reactor l_obj
31. ;; "elev-Reactor"
32. ;; '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied))
33. ;; )
34. ;; )
35. ;; )
36. ;;)
37. ;;(setq ss nil n nil ent nil l_obj nil)
38. ;;主程序
39.   (defun c:yad_elev(/ os lay ss insp text obj)
40.   (command "_.undo" "_be")
41.   (command "_.ucs" "")
42.   (setvar "cmdecho" 0)
43.   (setvar "dimzin" 0)
44.   (if (not (tblsearch "block" "yad_elev"))
45.   (progn (setq os (getvar "osmode") lay (getvar "clayer"))
46.   (setvar "osmode" 0)
47.   (setvar "clayer" "0")
48.   (setq ss (ssadd))
49.   (command "_.pline" "300,300" "_w" "0" "0" "0,0" "-300,300" "1300,300" "")
50.   (ssadd (entlast) ss)
51.   (command "_.attdef" "" "elev" "" "" "_s" "standard" "-100,400" "250" "0")
52.   (ssadd (entlast) ss) (command "_.block" "yad_elev" "0,0" ss "")
53.   (setvar "osmode" os) (setvar "clayer" lay) ) )
54.   (if (not (vlax-ldata-get "yad_dict" "elev"))
55.   (progn (setq insp
56.   (if (setq insp (getpoint "\n点取立剖面正负零标高的标注位置：")) insp '(0.0 0.0 0.0)))
57.   (setq text (- (cadr insp)))
58.   (vlax-ldata-put "yad_dict" "elev" text)
59.   (command "_.insert" "yad_elev" insp "1" "" "0" "%%p0.000")
60.   (setq obj (vlax-ename->vla-object (entlast)))
61.   (if (not elev-object-reactor)
62.   (setq elev-object-reactor (vlr-object-reactor (list obj) "elev-Reactor" '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied)) ) )
63.   (vlr-owner-add elev-object-reactor obj) )
64.   (if (vlax-object-released-p obj)
65.   (vlax-release-object obj) ) )
66.   (while (and (setq text (vlax-ldata-get "yad_dict" "elev"))
67.   (not (prompt (strcat "\n***当前正负零标高相当于屏幕Y轴坐标" (rtos (- text) 2 0) "***")))
68.   (not (initget "Ch")) (setq insp (getpoint "\n点取立剖面标高标注点[C 重新确认正负零标高的位置]："))
69.   )
70.   (if (= insp "Ch")
71.   (progn (setq text (getpoint "\n***注意：原有标高会自动更改***\n点取正负零标高的位置："))
72.   (if (and text (setq text (- (cadr text))) (not (equal text (vlax-ldata-get "yad_dict" "elev"))))
73.   (progn (vlax-ldata-put "yad_dict" "elev" text) (if (ssget "x" '((0 . "insert")(2 . "yad_elev")))
74.   (command "_.move" (ssget "x" '((0 . "insert")(2 . "yad_elev"))) "" "0,0" "0,0") ) ) ) )
75.   (progn (setq text (+ text (cadr insp)) text (if (equal text 0) "%%p0.000" (rtos (/ text 1000.0) 2 3)) )
76.   (command "_.insert" "yad_elev" insp "1" "" "0" text)
77.   (setq obj (vlax-ename->vla-object (entlast)))
78.   (if (not elev-object-reactor)
79.   (setq elev-object-reactor (vlr-object-reactor (list obj) "elev-Reactor" '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied)) ) ) (vlr-owner-add elev-object-reactor obj) )
80.   (if (vlax-object-released-p obj) (vlax-release-object obj) ) ) ) ) )
81.   (command "_.undo" "_e")
82.   (princ)
83.   )
84.   (prompt "\n*** 立面标高关联程序yad_elev *** YAD建筑") (princ)

;; ;;立面标高关联程序 ;; (vl-load-com) ;;标高反应器 (defun elev-record(owner-object reactor-object parameter-list)   (if (not (vlax-erased-p owner-object)) (setq elev-to-update (append elev-to-update (list owner-object))) ) ) (defun elev-copied(owner-object reactor-object parameter-list / new-ename) (setq elev-object-reactor reactor-object) (setq new-ename (car parameter-list)) (setq elev-to-update (append elev-to-update (list new-ename))) ) (defun commande (calling-reactor lst / elev-update-attr elev-object) (defun elev-update-attr(elev-object / elev-ename insp text attr-object) (setq elev-ename (vlax-vla-object->ename elev-object)) (setq insp (vla-get-InsertionPoint elev-object))   (setq insp (vlax-safearray->list (vlax-variant-value insp))) (setq text (rtos (/ (+ (cadr insp) (vlax-ldata-get "yad_dict" "elev")) 1000.0) 2 3)) (if (= text "0.000") (setq text "%%p0.000")) (setq attr-object (vlax-ename->vla-object (entnext elev-ename))) (vla-put-textstring attr-object text)   (if (vlax-object-released-p attr-object) (vlax-release-object attr-object) ) ) (if elev-to-update (progn (setq elev-to-update (vl-remove nil elev-to-update)) (foreach elev-object elev-to-update (if (= (type elev-object) 'ename) (progn (setq elev-object (vlax-ename->vla-object elev-object)) (vlr-owner-add elev-object-reactor elev-object) ) ) (if (vlax-erased-p elev-object) nil (elev-update-attr elev-object) ) (if (vlax-object-released-p elev-object) (vlax-release-object elev-object) ) ) (setq elev-to-update nil) ) ) (princ) ) (vlr-command-reactor nil '((:vlr-commandEnded . commande)))   ;;如果要确保图形下次打开时关联有效，请把以上代码及本段代码加入acad2000doc.lsp文件。 ;;(if (and (vlax-ldata-get "yad_dict" "elev") ;; (setq ss (ssget "x" '((0 . "insert")(2 . "yad_elev")))) ;; ) ;; (progn ;; (setq n -1) ;; (repeat (sslength ss) ;; (setq ent (ssname ss (setq n (1+ n)))) ;; (setq ent (vlax-ename->vla-object ent)) ;; (setq l_obj (append l_obj (list ent))) ;; ) ;; (setq elev-object-reactor ;; (vlr-object-reactor l_obj ;; "elev-Reactor" ;; '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied)) ;; ) ;; ) ;; ) ;;) ;;(setq ss nil n nil ent nil l_obj nil) ;;主程序   (defun c:yad_elev(/ os lay ss insp text obj)   (command "_.undo" "_be")   (command "_.ucs" "")   (setvar "cmdecho" 0)   (setvar "dimzin" 0)   (if (not (tblsearch "block" "yad_elev"))   (progn (setq os (getvar "osmode") lay (getvar "clayer"))   (setvar "osmode" 0)   (setvar "clayer" "0")   (setq ss (ssadd))   (command "_.pline" "300,300" "_w" "0" "0" "0,0" "-300,300" "1300,300" "")   (ssadd (entlast) ss)   (command "_.attdef" "" "elev" "" "" "_s" "standard" "-100,400" "250" "0")   (ssadd (entlast) ss) (command "_.block" "yad_elev" "0,0" ss "")   (setvar "osmode" os) (setvar "clayer" lay) ) )   (if (not (vlax-ldata-get "yad_dict" "elev"))   (progn (setq insp   (if (setq insp (getpoint "\n点取立剖面正负零标高的标注位置：")) insp '(0.0 0.0 0.0)))   (setq text (- (cadr insp)))   (vlax-ldata-put "yad_dict" "elev" text)   (command "_.insert" "yad_elev" insp "1" "" "0" "%%p0.000")   (setq obj (vlax-ename->vla-object (entlast)))   (if (not elev-object-reactor)   (setq elev-object-reactor (vlr-object-reactor (list obj) "elev-Reactor" '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied)) ) )   (vlr-owner-add elev-object-reactor obj) )   (if (vlax-object-released-p obj)   (vlax-release-object obj) ) )   (while (and (setq text (vlax-ldata-get "yad_dict" "elev"))   (not (prompt (strcat "\n***当前正负零标高相当于屏幕Y轴坐标" (rtos (- text) 2 0) "***")))   (not (initget "Ch")) (setq insp (getpoint "\n点取立剖面标高标注点[C 重新确认正负零标高的位置]："))   )   (if (= insp "Ch")   (progn (setq text (getpoint "\n***注意：原有标高会自动更改***\n点取正负零标高的位置："))   (if (and text (setq text (- (cadr text))) (not (equal text (vlax-ldata-get "yad_dict" "elev"))))   (progn (vlax-ldata-put "yad_dict" "elev" text) (if (ssget "x" '((0 . "insert")(2 . "yad_elev")))   (command "_.move" (ssget "x" '((0 . "insert")(2 . "yad_elev"))) "" "0,0" "0,0") ) ) ) )   (progn (setq text (+ text (cadr insp)) text (if (equal text 0) "%%p0.000" (rtos (/ text 1000.0) 2 3)) )   (command "_.insert" "yad_elev" insp "1" "" "0" text)   (setq obj (vlax-ename->vla-object (entlast)))   (if (not elev-object-reactor)   (setq elev-object-reactor (vlr-object-reactor (list obj) "elev-Reactor" '((:vlr-ObjectClosed . elev-record) (:vlr-Copied . elev-copied)) ) ) (vlr-owner-add elev-object-reactor obj) )   (if (vlax-object-released-p obj) (vlax-release-object obj) ) ) ) ) )   (command "_.undo" "_e")   (princ)   )   (prompt "\n*** 立面标高关联程序yad_elev *** YAD建筑") (princ)