大神们，能将旧的字text删除吗，弄了半天还是不行
(defun c:taat(/ s1 t2 sstoes p b l);;用了自贡黄明儒的通用排序函数
(defun SstoEs(ss / a en lst)
(if ss(progn(setq a -1)
(while(setq en(ssname ss(setq a(1+ a)))
)(setq lst (cons en lst)))))
lst);defun end
(defun ssPtsSort(ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS);;by自贡黄明儒 2013年9月9日
(defun sortpts (PTS FUN xyz FUZZ)
(vl-sort pts'(lambda (a b)(if(not(equal(xyz a)(xyz b)fuzz))(fun(xyz a)(xyz b)))))
)
(defun sortpts1 (PTS KEY FUZZ)
(setq Key (vl-string->list Key))
(foreach xyz (reverse Key)
(cond ((< xyz 100)
(setq fun >
xyz(nth(- xyz 88)(list car cadr caddr))))
(T(setq fun <
xyz(nth(- xyz 120)(list car cadr caddr)))))
(setq Pts(sortpts Pts fun xyz fuzz)
))
)
(cond((=(type ssPts)'PICKSET)
(repeat(setq n(sslength ssPts))
(if(and(setq e(ssname ssPts(setq n(1- n))))
(setq en(entget e))
)
(setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))))
(mapcar 'last (sortpts1 lst KEY FUZZ)))
((Listp ssPts)(cond ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
((= (type (car ssPts)) 'ENAME)
(foreach e ssPts(if(setq en(entget e))(setq lst(cons(append(cdr(assoc 10 en))(list e))lst))))
(mapcar'last(sortpts1 lst KEY FUZZ)))))
)
);defun end
(prompt "请选择要合并为多行文本的单行文字对象")
(setq s1(SstoEs(ssget'((0 . "TEXT"))))T2"")
(if s1(progn
(setq s1 (ssPtsSort s1 "Yx" 0.5)
b(entget(car s1))
t2(cdr(assoc 1 b))l 1)
(foreach a(cdr s1)(setq c(cdr(assoc 1(entget a)))l(if(>(strlen c)l)(strlen c)l)t2(strcat t2"\\P"c)))
(while(null(setq p(getpoint"指定多行文本左上角点"))))
(entmake(list(cons 0 "MTEXT")(cons 100 "AcDbEntity")(cons 100"AcDbMText")(cons 10 P)(assoc 40 b)
(cons 41 (* l (cdr(assoc 40 b))))(cons 1 t2)(assoc 7 b)(cons 71 1)(cons 73 1))))
)
)
在最后的 entmake 后面加上一行 (foreach a s1 (entdel a)) 应该就可以了吧。 没细看，但感觉小伙有前途
页:
[1]