找到lyy在2003年写的程序，现在有没有更简洁的写法（有关反应器）
下面这段是lyy在2003年发的程序，在CAD2008里测试是可以用的，只是图块是程序画的，不能用自己的属性块。其实执行过程中是不没必要跳出那个让人填写的EVEV属性值的对话框的，写了也没用，点“确定”后值也是会自动变成程序测量的数值，好像多此一举（还是我还没测出其它方面用处？）。
另外就是被参照的基准点不能移动，有没办法实现参照点也可以移动？也就是移动这个基准点（可以是直线的一端点或块的插入点）时其它参照它的标高值也能自动跟着变？
不知5年后的今天有没有更简洁的写法？
;; ;;立面标高关联程序 ;;
(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点取立剖面标高标注点："))
)
(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)
页:
[1]