[原创]立面标高关联程序！

lyy

;;
;;立面标高关联程序
;;

(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)

tuger

lyy,你好厉害哦。高手啊

czb203

真得很好用啊谢谢

skg123

程序不错，要是能让用户 自定义 三角 符号的大小就更好了 比如在1:1的图上用

luojunmax

太强了

szx025

好程序，但应该加一个取消关联的设置，因为图纸完成后，可能需要调整图面布置，这时就不需要标高跟着改动。另;1，标高三角下面应该有一短直线,2，文字高度250是否有点小

注册

      (command "_.attdef" "" "elev" "" "" "_s" "standard" "-100,400" "250" "0") 修改此句的250到300的话还是没法将标高文字高度调整为300呢？

注册

可以了-----