学习了，能否改进下成为支持块的
程序不错，但是不支持块 现在天正弄出来的标高 都是块，
理正的也是如此啊
userzhl 发表于 2009-5-27 14:54 static/image/common/back.gif
只支持“TEXT"MTEXT"意义不大，若能支持属性块的话就好了。
支持属性块的标高
http://bbs.mjtd.com/thread-91303-1-1.html
此贴持续关注中
;;复制标高，标高数字自动修改
(defun c:t ()
;(PXT_ER)
(defun DXF (n da) (cdr (assoc n da)))
(setq xtblm '("osmode" "clayer" "cecolor" "orthomode" "plinewid")
xtblz (mapcar 'getvar xtblm)
)
(setvar "osmode" 1) ;_捕捉端点
(princ "\n请选择要复制\"图层为_B标高\"的标高(退出)：")
;;;(setq ss (ssget ":L"
;;; (list (cons 8 "B标高"))
;;; )
;;;)
(setq ss (ssget))
(if ss
(progn
(command "undo" "be")
(if (null bl-cb)
(setq bl-cb 1.0)
)
(prompt (strcat "\n当前缩放比例:【" (rtos bl-cb 2 1) "】"))
(initget "Bili")
(setq p1 (getpoint "\nBili改变比例/ 基点(退出)："))
(while (= p1 "Bili")
(setq
bl-cb2
(getreal (strcat "\n请输入比例:<" (rtos bl-cb 2 1) ">")
)
)
(if bl-cb2
(setq bl-cb bl-cb2)
(setq bl-cb bl-cb)
)
(prompt (strcat "\n当前缩放比例:【" (rtos bl-cb 2 1) "】"))
(initget "Bili")
(setq p1 (getpoint "\nBili改变比例/ 基点(退出)："))
)
;;--------------------------------------------
(setvar "osmode" 673) ;_捕捉端点、交叉点、最近点 垂足
(while (setq p2 (getpoint p1 "\n拷贝至 (退出): "))
;;-------------------------------
;; 返回复制后，新生成的物体ss_new
(setq en_Last (entlast)
ss_new(ssadd)
)
(command "copy" ss "" p1 p2)
(setq en_next (entnext en_Last))
(while en_next
(ssadd en_next ss_new)
(setq en_next (entnext en_next))
)
;;------------------------------
(setq i 0)
(repeat (sslength ss_new)
(setq en (ssname ss_new i)
da (entget en)
enty (DXF 0 da)
)
(cond
;;处理：普通标高text 天正标高
((member enty (list "TEXT" "TCH_ELEVATION"))
(setq txt (DXF 1 da))
(if (or (= txt "%%p0.000")
(= txt "0") ;_Tch标高为 (1 . "0")
(and (/= (atof txt) 0)
(wcmatch txt "*.*")
)
)
(progn
;;--计算高差----
(setq d (- (cadr p2) (cadr p1))
d (* d 0.001 bl-cb)
num (+ (atof txt) d)
)
(setq txt-n (rtos num 2 3))
(if (= txt-n "0.000")
(setq txt-n "%%p0.000")
)
;;-------------
(setq da (subst (cons 1 txt-n) (assoc 1 da) da))
(entmod da)
)
)
)
;;处理：属性标高
((member enty (list "INSERT"))
(setq da(entget (entnext en))
txt (DXF 1 da)
)
;;--计算高差----
(setq d (- (cadr p2) (cadr p1))
d (* d 0.001 bl-cb)
num (+ (atof txt) d)
)
(setq txt-n (rtos num 2 3))
(if (= txt-n "0.000")
(setq txt-n "%%p0.000")
)
;;-------------
;;============================
;; 替换属性文字
(setq da (entget (entnext en)))
(setq da (subst (cons 1 txt-n) (assoc 1 da) da))
(entmod da)
(entupd en)
(entupd (entnext en))
;;============================
)
) ;_ cond
(setq i (1+ i))
) ;_end repeat
) ;_end while
(command "undo" "e")
)
) ;_ if ss
(mapcar 'setvar xtblm xtblz)
(princ)
)
楼上的不错，谢谢额
还可以 ~~
挺好用的，若能够做活了就更好了。
谢谢楼主的分享
收藏了，学习学习