【求助】单行文字转多行文字

iszc

帮忙写个lsp
如图，将单行文字合并为多行文字，要求合并后按照从左至右的顺序排序

自贡黄明儒

;;这个问题，好象本论坛很多的嘛
;;下面是我下载，谁写的不记得了，敬请原谅

1. (defun TextToMText
   
2.                      (/ BLST BOX BOXL E EL H L N OLDH OLDST PY SS SSL ST STRL X)
   
3.     (if        (setq ss (ssget '((0 . "text"))))
   
4.       (progn
   
5.         (setq
   
6.           ssl        (sslength ss)
   
7.           n        -1
   
8.           oldh        (getvar "textsize")
   
9.           oldst        (getvar "textstyle")
   
10.         )
    
11.         (repeat        ssl
    
12.           (setq
    
13.             e         (ssname ss (setq n (1+ n)))
    
14.             el         (entget e)
    
15.             box         (textbox (vl-remove (assoc 50 el) el))
    
16.             boxl (cons box boxl)
    
17.             l         (+ (abs (caadr box)) (abs (cadadr box)))
    
18.             blst (cons l blst)
    
19.             strl (cons
    
20.                    (list (cdr (assoc 10 el)) (cdr (assoc 1 el)))
    
21.                    strl
    
22.                  )
    
23.             h         (if (and h (> (cdr (assoc 40 el)) h))
    
24.                    (setq h (cdr (assoc 40 el)))
    
25.                    (setq h (cdr (assoc 40 el)))
    
26.                  )
    
27.             st         (if (not st)
    
28.                    (cdr (assoc 7 el))
    
29.                    st
    
30.                  )
    
31.           )
    
32.         )
    
33.         (setvar "textsize" h)
    
34.         (if (/= (getvar "textstyle") st)
    
35.           (setvar "textstyle" st)
    
36.         )
    
37.         (setq
    
38.           strl (vl-sort        strl
    
39.                         '(lambda (e1 e2)
    
40.                            (if (equal (cadar e1) (cadar e2) 0.00001)
    
41.                              (< (caar e1) (caar e2))
    
42.                              (> (cadar e1) (cadar e2))
    
43.                            )
    
44.                          )
    
45.                )
    
46.           py   (apply 'max (mapcar 'cadr (apply 'append boxl)))
    
47.         )
    
48.         (vla-addmtext
    
49.           (vla-get-modelspace
    
50.             (vla-get-activedocument
    
51.               (vlax-get-acad-object)
    
52.             )
    
53.           )
    
54.           (vlax-3d-point
    
55.             (list (caaar strl) (+ py (cadaar strl)))
    
56.           )
    
57.           (apply 'max blst)
    
58.           (apply 'strcat
    
59.                  (mapcar
    
60.                    '(lambda (x)
    
61.                       (strcat (last x) "\\P")
    
62.                     )
    
63.                    strl
    
64.                  )
    
65.           )
    
66.         )
    
67.         (command ".erase" ss "")
    
68.         (setvar "textsize" oldh)
    
69.         (setvar "textstyle" oldst)
    
70.       )
    
71.     )
    
72.   )
    
73. 
    
74.   ;;1.2 Mtext转text
    
75.   (defun MtextToText (/ EN N SS)
    
76.     (setq ss (ssget (list (cons 0 "MTEXT"))))
    
77.     (if        ss
    
78.       (repeat (setq n (sslength ss))
    
79.         (setq en (ssname ss (setq n (1- n))))
    
80.         (command "_.explode" en)
    
81.       )
    
82.     )
    
83.   )

(defun TextToMText<br />                      (/ BLST BOX BOXL E EL H L N OLDH OLDST PY SS SSL ST STRL X)<br />     (if        (setq ss (ssget '((0 . "text"))))<br />       (progn<br />         (setq<br />           ssl        (sslength ss)<br />           n        -1<br />           oldh        (getvar "textsize")<br />           oldst        (getvar "textstyle")<br />         )<br />         (repeat        ssl<br />           (setq<br />             e         (ssname ss (setq n (1+ n)))<br />             el         (entget e)<br />             box         (textbox (vl-remove (assoc 50 el) el))<br />             boxl (cons box boxl)<br />             l         (+ (abs (caadr box)) (abs (cadadr box)))<br />             blst (cons l blst)<br />             strl (cons<br />                    (list (cdr (assoc 10 el)) (cdr (assoc 1 el)))<br />                    strl<br />                  )<br />             h         (if (and h (> (cdr (assoc 40 el)) h))<br />                    (setq h (cdr (assoc 40 el)))<br />                    (setq h (cdr (assoc 40 el)))<br />                  )<br />             st         (if (not st)<br />                    (cdr (assoc 7 el))<br />                    st<br />                  )<br />           )<br />         )<br />         (setvar "textsize" h)<br />         (if (/= (getvar "textstyle") st)<br />           (setvar "textstyle" st)<br />         )<br />         (setq<br />           strl (vl-sort        strl<br />                         '(lambda (e1 e2)<br />                            (if (equal (cadar e1) (cadar e2) 0.00001)<br />                              (< (caar e1) (caar e2))<br />                              (> (cadar e1) (cadar e2))<br />                            )<br />                          )<br />                )<br />           py   (apply 'max (mapcar 'cadr (apply 'append boxl)))<br />         )<br />         (vla-addmtext<br />           (vla-get-modelspace<br />             (vla-get-activedocument<br />               (vlax-get-acad-object)<br />             )<br />           )<br />           (vlax-3d-point<br />             (list (caaar strl) (+ py (cadaar strl)))<br />           )<br />           (apply 'max blst)<br />           (apply 'strcat<br />                  (mapcar<br />                    '(lambda (x)<br />                       (strcat (last x) "\\P")<br />                     )<br />                    strl<br />                  )<br />           )<br />         )<br />         (command ".erase" ss "")<br />         (setvar "textsize" oldh)<br />         (setvar "textstyle" oldst)<br />       )<br />     )<br />   )<br /> <br />   ;;1.2 Mtext转text<br />   (defun MtextToText (/ EN N SS)<br />     (setq ss (ssget (list (cons 0 "MTEXT"))))<br />     (if        ss<br />       (repeat (setq n (sslength ss))<br />         (setq en (ssname ss (setq n (1- n))))<br />         (command "_.explode" en)<br />       )<br />     )<br />   )

llsheng_73

1. (defun c:tt(/ s1 t2 sstoes p b l);;用了自贡黄明儒的通用排序函数
   
2.   (defun SstoEs(ss / a en lst)
   
3.     (if ss(progn(setq a -1)
   
4.       (while(setq en(ssname ss(setq a(1+ a))))(setq lst (cons en lst)))))
   
5.     lst);defun end
   
6.   (defun ssPtsSort(ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS);;by自贡黄明儒 2013年9月9日
   
7.     (defun sortpts (PTS FUN xyz FUZZ)
   
8.       (vl-sort pts'(lambda (a b)(if(not(equal(xyz a)(xyz b)fuzz))(fun(xyz a)(xyz b)))))
   
9.       )
   
10.   (defun sortpts1 (PTS KEY FUZZ)
    
11.     (setq Key (vl-string->list Key))
    
12.      (foreach xyz (reverse Key)
    
13.        (cond ((< xyz 100)
    
14.        (setq fun >
    
15.       xyz(nth(- xyz 88)(list car cadr caddr))))
    
16.       (T(setq fun <
    
17.        xyz(nth(- xyz 120)(list car cadr caddr)))))
    
18.        (setq Pts(sortpts Pts fun xyz fuzz)))
    
19.     )
    
20.     (cond((=(type ssPts)'PICKSET)
    
21.    (repeat(setq n(sslength ssPts))
    
22.      (if(and(setq e(ssname ssPts(setq n(1- n))))
    
23.      (setq en(entget e)))
    
24.        (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))))
    
25.    (mapcar 'last (sortpts1 lst KEY FUZZ)))
    
26.   ((Listp ssPts)(cond ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
    
27.         ((= (type (car ssPts)) 'ENAME)
    
28.          (foreach e ssPts(if(setq en(entget e))(setq lst(cons(append(cdr(assoc 10 en))(list e))lst))))
    
29.          (mapcar'last(sortpts1 lst KEY FUZZ)))))
    
30.   )
    
31.     );defun end
    
32.   (prompt "请选择要合并为多行文本的单行文字对象")
    
33.   (setq s1(SstoEs(ssget'((0 . "TEXT"))))T2"")
    
34.   (if s1(progn
    
35.     (setq s1 (ssPtsSort s1 "Yx" 0.5)
    
36.    b(entget(car s1))
    
37.    t2(cdr(assoc 1 b))l 1)
    
38.     (foreach a(cdr s1)(setq c(cdr(assoc 1(entget a)))l(if(>(strlen c)l)(strlen c)l)t2(strcat t2"\\P"c)))
    
39.     (while(null(setq p(getpoint"指定多行文本左上角点"))))
    
40.     (entmake(list(cons 0 "MTEXT")(cons 100 "AcDbEntity")(cons 100  "AcDbMText")(cons 10 P)(assoc 40 b)
    
41.            (cons 41 (* l (cdr(assoc 40 b))))(cons 1 t2)(assoc 7 b)(cons 71 1)(cons 73 1)))))
    
42.   )

(defun c:tt(/ s1 t2 sstoes p b l);;用了自贡黄明儒的通用排序函数<br />   (defun SstoEs(ss / a en lst)<br />     (if ss(progn(setq a -1)<br />       (while(setq en(ssname ss(setq a(1+ a))))(setq lst (cons en lst)))))<br />     lst);defun end<br />   (defun ssPtsSort(ssPts KEY FUZZ / E EN FUN LST N SORTPTS SORTSS);;by自贡黄明儒 2013年9月9日<br />     (defun sortpts (PTS FUN xyz FUZZ)<br />       (vl-sort pts'(lambda (a b)(if(not(equal(xyz a)(xyz b)fuzz))(fun(xyz a)(xyz b)))))<br />       )<br />   (defun sortpts1 (PTS KEY FUZZ)<br />     (setq Key (vl-string->list Key))<br />      (foreach xyz (reverse Key)<br />        (cond ((< xyz 100)<br />        (setq fun ><br />       xyz(nth(- xyz 88)(list car cadr caddr))))<br />       (T(setq fun <<br />        xyz(nth(- xyz 120)(list car cadr caddr)))))<br />        (setq Pts(sortpts Pts fun xyz fuzz)))<br />     )<br />     (cond((=(type ssPts)'PICKSET)<br />    (repeat(setq n(sslength ssPts))<br />      (if(and(setq e(ssname ssPts(setq n(1- n))))<br />      (setq en(entget e)))<br />        (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))))<br />    (mapcar 'last (sortpts1 lst KEY FUZZ)))<br />   ((Listp ssPts)(cond ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))<br />         ((= (type (car ssPts)) 'ENAME)<br />          (foreach e ssPts(if(setq en(entget e))(setq lst(cons(append(cdr(assoc 10 en))(list e))lst))))<br />          (mapcar'last(sortpts1 lst KEY FUZZ)))))<br />   )<br />     );defun end<br />   (prompt "请选择要合并为多行文本的单行文字对象") <br />   (setq s1(SstoEs(ssget'((0 . "TEXT"))))T2"")<br />   (if s1(progn<br />     (setq s1 (ssPtsSort s1 "Yx" 0.5)<br />    b(entget(car s1))<br />    t2(cdr(assoc 1 b))l 1)<br />     (foreach a(cdr s1)(setq c(cdr(assoc 1(entget a)))l(if(>(strlen c)l)(strlen c)l)t2(strcat t2"<a href="http://bbs.mjtd.com/file://\\P" target="_blank">\\P"c</a>)))<br />     (while(null(setq p(getpoint"指定多行文本左上角点"))))<br />     (entmake(list(cons 0 "MTEXT")(cons 100 "AcDbEntity")(cons 100  "AcDbMText")(cons 10 P)(assoc 40 b)<br />            (cons 41 (* l (cdr(assoc 40 b))))(cons 1 t2)(assoc 7 b)(cons 71 1)(cons 73 1)))))<br />   )

还是老黄的通用排序强大!!!

llsheng_73

已经按你说的作了点小修改，附件也更新了。。。

iszc

llsheng_73 发表于 2013-11-9 13:08
已经按你说的作了点小修改，附件也更新了。。。

测试还是不理想 如图

iszc

自贡黄明儒 发表于 2013-11-9 14:40
;;这个问题，好象本论坛很多的嘛
;;下面是我下载，谁写的不记得了，敬请原谅

不好意思，加载错误

iszc

iszc 发表于 2013-11-9 14:49
不好意思，加载错误

已成功加载 合并单行文字1.lsp

命令: ; 错误: *error* 函数中出错参数类型错误: lselsetp nil

llsheng_73

自贡黄明儒 发表于 2013-11-9 14:40
;;这个问题，好象本论坛很多的嘛
;;下面是我下载，谁写的不记得了，敬请原谅

其实程序很简单，关键就在排序上，最后我直接用了你分享的通用排序函数

llsheng_73

自贡黄明儒 发表于 2013-11-9 14:40
;;这个问题，好象本论坛很多的嘛
;;下面是我下载，谁写的不记得了，敬请原谅

MTEXT->TEXT直接EXPLODE？记得好象有时会多一些控制字符在单行文本里边

iszc

二位确实很厉害，谢谢帮忙