[原创]LISP的[复制标高后同时改变标高数字]程序，开源
看了subtlation的贴子有这么多人在问源码，今天就发一个，这只是一个最基本的，有很大的扩充空间。希望对大家有用。(defun c:cbg()
(setq bg (ssget));取得标高标注的对象（本程序中标高标注的字串必须为文字，不能为属性，而且也不能是块内的文字）
(setq i (sslength bg)
j 0)
;--------------------------------------
(while (< j i);遍历选择集对象
(setq obj (ssname bg j))
(setq obj (entget obj))
(setq tmp (cdr (assoc 0 obj)))
(if (or (= tmp "TEXT") (= tmp "MTEXT") );(= tmp "INSERT"));如果选择集中有对象是文字则
(progn
(setq j i);准备退出循环
(setq is_OK t);设置标识
(setq ist_pt (cdr (assoc 10 obj)));并取得当前文字对象的坐标用于在复制后选取文字对象
)
)
(setq j (1+ j))
)
;------------------------------------
(if (not is_OK);如果标识为假则退出程序
(progn
(alert "没有文字性标记")
(exit)
)
)
;-----------开始复制-------------
(setq pt1 (getpoint "选择基点:"))
(command "copy" bg "" pt1)
(setq pt2 (getpoint pt1))
(command pt2)
;----------开始修改复制后标高的文字标注-----------
(setq dlt_y (- (cadr pt2) (cadr pt1)));先计算Y的增量
(setq ist_pt (subst (+ (cadr ist_pt) dlt_y) (cadr ist_pt) ist_pt));按Y增量计算复制的新对象的坐标
(setq new_tag (ssget "x" (list (cons 10 ist_pt))));按这个新坐标来选取对象
;注意，这种选取只能对垂直方向复制有效，如果X坐标发生改变，则这个选取方法也要调整X坐标
;为了简单，本程序没有处理X坐标
(setq obj (ssname new_tag 0))
(setq obj (entget obj));提取选择集中的文字对象
(setq tag_val (cdr (assoc 1 obj)));取文字对象的值
(setq tag_val (atof (substr tag_val 2)));去掉前面的符号，并转换成数字（这里没有考滤负号的情况）
(setq tag_val (+ tag_val (/ dlt_y 1000)));将标高值加上一个Y增量
(setq tag_val (rtos tag_val));并转换为文本格式
;判断在标高前加什么符号
(if (> (atof tag_val) 0)
(setq tag_val (strcat "+" tag_val)))
(if (= (atof tag_val) 0)
(setq tag_val (strcat "%%P" tag_val)))
;将标高转换为点对，用于SUBST函数替换原来的标高字符
(setq tag_val (cons 1 tag_val))
(setq obj (subst tag_val (assoc 1 obj) obj));替换
(entmod obj);修改数据
(entupd (ssname new_tag 0));更新数据
)
userzhl 发表于 2009-5-27 14:54 static/image/common/back.gif
只支持“TEXT"MTEXT"意义不大，若能支持属性块的话就好了。
支持属性块的标高
http://bbs.mjtd.com/thread-91303-1-1.html 本帖最后由 alexmai 于 2017-10-26 19:50 编辑
pxt2001 发表于 2012-7-15 10:49
;;复制标高，标高数字自动修改
(defun c:t ()
;(PXT_ER)
这个标高程序很好用，但想调整功能：
计算后的标高结果，若为正数，想在数字前加上"+"
即3.000 （显示为→） +3.000
0.015 （显示为→） +0.015
--------------------------------
我也知道是改这里，但苦于没找到加前序的函数 “+”
如果能指点一下就更好，谢谢！
;; 替换属性文字
(setq da (entget (entnext en)))
(setq da (subst (cons 1 txt-n) (assoc 1 da) da))
(entmod da)
(entupd en)
(entupd (entnext en))
<p><font color="#000000">只支持<font color="#ff00ff">“TEXT"MTEXT"</font>意义不大，若能支持属性块的话就好了。</font></p> 多谢分享，继续学习。 多谢分享 多谢分享，用了下，估计还要根据自己习惯修理修理 还真得修理修理 谢谢楼主的分享
收藏了，学习学习 程序不错，如果能保留小数点后面的零就更好了 程序不错，但是不支持块 现在天正弄出来的标高 都是块， 感谢分享