看了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));更新数据
- )
| 
[复制链接]
发表于 2009-5-26 21:02:00
置顶卡
变色卡
显身卡
发表于 2012-4-25 21:00:13
多谢分享