Text转Mtext

自贡黄明儒

我希望—个单行文本对象，转成多行文字，转换后看起来位置基本不变。原来在论坛上看到过，今天搜了半天也没找到，请各位高人邦—下忙，币不多，是个意思

ZZXXQQ

觉得TENT开始的数据要反过来，这样在后面再次颠倒时才正确。
MTEXT的插入点在左上角，这可以用函数计算出来。

香田里浪人

(defun c:tt(/ 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)))))
  )

香田里浪人

l楼主是高手，这个问题应该难不倒楼主，我想楼主是会编的。

自贡黄明儒

香田里浪人 发表于 2014-1-27 19:45
l楼主是高手，这个问题应该难不倒楼主，我想楼主是会编的。

你的是多个Text，太复杂了，我希望是—个

繁花落叶

希望有用。

2. ;;; Add MText to drawing
   
3. ;;; #InsertionPoint - MText insertion point
   
4. ;;; #String - String to place in created MText object
   
5. ;;; #Width - Width of MText object (if nil, will be 0 width)
   
6. ;;; #Layer - Layer to place Mtext object on (nil for current)
   
7. ;;; #Justification - Justification # for Mtext object
   
8. ;;;                     1 or nil= TopLeft
   
9. ;;;                     2= TopCenter
   
10. ;;;                     3= TopRight
    
11. ;;;                     4= MiddleLeft
    
12. ;;;                     5= MiddleCenter
    
13. ;;;                     6= MiddleRight
    
14. ;;;                     7= BottomLeft
    
15. ;;;                     8= BottomCenter
    
16. ;;;                     9= BottomRight
    
17. ;;; Alan J. Thompson, 05.23.09
    
18. (defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
    
19.                  #Space #Insertion #Object
    
20.                 )
    
21.   (or #Width (setq #Width 0))
    
22.   (or *AcadDoc*
    
23.       (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
    
24.   ) ;_ or
    
25.   (setq #Space     (if (or (eq acmodelspace
    
26.                                (vla-get-activespace *AcadDoc*)
    
27.                            ) ;_ eq
    
28.                            (eq :vlax-true (vla-get-mspace *AcadDoc*))
    
29.                        ) ;_ or
    
30.                      (vla-get-modelspace *AcadDoc*)
    
31.                      (vla-get-paperspace *AcadDoc*)
    
32.                    ) ;_ if
    
33.         #Insertion (cond
    
34.                      ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
    
35.                      ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
    
36.                      (T nil)
    
37.                    ) ;_ cond
    
38.   ) ;_ setq
    
39.   ;; create MText object
    
40.   (setq #Object (vla-addmtext #Space #Insertion #Width #String))
    
41.   ;; change layer, if applicable
    
42.   (and #Layer
    
43.        (tblsearch "layer" #Layer)
    
44.        (vla-put-layer #Object #Layer)
    
45.   ) ;_ and
    
46.   ;; change justification & match insertion point with new justification
    
47.   (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
    
48.          (vla-put-attachmentpoint #Object #Justification)
    
49.          (vla-move #Object
    
50.                    (vla-get-InsertionPoint #Object)
    
51.                    #Insertion
    
52.          ) ;_ vla-move
    
53.         )
    
54.   ) ;_ cond
    
55.   #Object
    
56. ) ;_ defun

;;; Add MText to drawing<br /> ;;; #InsertionPoint - MText insertion point<br /> ;;; #String - String to place in created MText object<br /> ;;; #Width - Width of MText object (if nil, will be 0 width)<br /> ;;; #Layer - Layer to place Mtext object on (nil for current)<br /> ;;; #Justification - Justification # for Mtext object<br /> ;;;                     1 or nil= TopLeft<br /> ;;;                     2= TopCenter<br /> ;;;                     3= TopRight<br /> ;;;                     4= MiddleLeft<br /> ;;;                     5= MiddleCenter<br /> ;;;                     6= MiddleRight<br /> ;;;                     7= BottomLeft<br /> ;;;                     8= BottomCenter<br /> ;;;                     9= BottomRight<br /> ;;; Alan J. Thompson, 05.23.09<br /> (defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width<br />                  #Space #Insertion #Object<br />                 )<br />   (or #Width (setq #Width 0))<br />   (or *AcadDoc*<br />       (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))<br />   ) ;_ or<br />   (setq #Space     (if (or (eq acmodelspace<br />                                (vla-get-activespace *AcadDoc*)<br />                            ) ;_ eq<br />                            (eq :vlax-true (vla-get-mspace *AcadDoc*))<br />                        ) ;_ or<br />                      (vla-get-modelspace *AcadDoc*)<br />                      (vla-get-paperspace *AcadDoc*)<br />                    ) ;_ if<br />         #Insertion (cond<br />                      ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))<br />                      ((eq (type #InsertionPoint) 'variant) #InsertionPoint)<br />                      (T nil)<br />                    ) ;_ cond<br />   ) ;_ setq<br />   ;; create MText object<br />   (setq #Object (vla-addmtext #Space #Insertion #Width #String))<br />   ;; change layer, if applicable<br />   (and #Layer<br />        (tblsearch "layer" #Layer)<br />        (vla-put-layer #Object #Layer)<br />   ) ;_ and<br />   ;; change justification & match insertion point with new justification<br />   (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))<br />          (vla-put-attachmentpoint #Object #Justification)<br />          (vla-move #Object<br />                    (vla-get-InsertionPoint #Object)<br />                    #Insertion<br />          ) ;_ vla-move<br />         )<br />   ) ;_ cond<br />   #Object<br /> ) ;_ defun

自贡黄明儒

香田里浪人 发表于 2014-1-27 19:45
l楼主是高手，这个问题应该难不倒楼主，我想楼主是会编的。

高手实不敢当。我只不过熟读唐诗三百首而已。你最后贴的代码在手机上看不见，明天好好学习—下。对MText控制点我还不熟习

重慶崽兒

大大好，小弟有个思路不知是否可行：
首先，替换组码肯定是行不通了，那么只好创建了。
通过组码表找到需要转换的单行文字的内容、样式、大小等等，然后通过程序取得“MTEXT”的entmake最少关键元素（只有三个，肯定不够完善），比如插入点就没有，至于大大说的位置不能变，小弟的想法是：创建多行文字默认的插入点是左上方，而单行文字的插入点是左下方，所以必须修改多行文字插入点的位置，也就是71这个组码，默认的是（71 . 1）这是左上，需要修改成（71 . 7）变成左下，最后加上创建多行文字的关键元素，以及字高，样式……等等创建，最最后，用(detdel 图元名)删除那个单行文字，完毕！
    额......   以上就是小弟愚见，还望大大莫笑，各位看官莫笑！

自贡黄明儒

重慶崽兒 发表于 2014-1-27 21:58
大大好，小弟有个思路不知是否可行：
首先，替换组码肯定是行不通了，那么只好创建了。
通过组码表找到需 ...

谢谢，分析得透彻，赞

自贡黄明儒

重慶崽兒 发表于 2014-1-27 21:58
大大好，小弟有个思路不知是否可行：
首先，替换组码肯定是行不通了，那么只好创建了。
通过组码表找到需 ...

这是我昨天写的，有点问题

1. ;;单行文字变多行文字
   
2. (defun text2mtext (e / EN ILIST TENT)
   
3.   (setq en (entget e))
   
4.   (Setq TENT '((0 . "MTEXT")(100 . "AcDbMText")))
   
5.   (ForEach INUM        '(7 8 10 40 41 71 72 1 7 11 42 43 50 73)
   
6.     (If        (Setq ILIST (Assoc INUM en))
   
7.       (Setq TENT (Cons ILIST TENT))
   
8.     )
   
9.   )  
   
10.   (entdel e)
    
11.   (EntMake (Reverse TENT))
    
12. )

;;单行文字变多行文字<br /> (defun text2mtext (e / EN ILIST TENT)<br />   (setq en (entget e))<br />   (Setq TENT '((0 . "MTEXT")(100 . "AcDbMText")))<br />   (ForEach INUM        '(7 8 10 40 41 71 72 1 7 11 42 43 50 73)<br />     (If        (Setq ILIST (Assoc INUM en))<br />       (Setq TENT (Cons ILIST TENT))<br />     )<br />   )  <br />   (entdel e)<br />   (EntMake (Reverse TENT))<br /> )