[原创]立面标高关联程序！
;;;;立面标高关联程序
;;
(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) lyy,你好厉害哦。高手啊 真得很好用啊谢谢 程序不错，要是能让用户 自定义 三角 符号的大小就更好了 比如在1:1的图上用 太强了 好程序，但应该加一个取消关联的设置，因为图纸完成后，可能需要调整图面布置，这时就不需要标高跟着改动。另;1，标高三角下面应该有一短直线,2，文字高度250是否有点小 (command "_.attdef" "" "elev" "" "" "_s" "standard" "-100,400" "250" "0") 修改此句的250到300的话还是没法将标高文字高度调整为300呢？ 可以了-----
页:
[1]