Text转Mtext
本帖最后由 自贡黄明儒 于 2014-1-27 18:57 编辑我希望—个单行文本对象，转成多行文字，转换后看起来位置基本不变。原来在论坛上看到过，今天搜了半天也没找到，请各位高人邦—下忙，币不多，是个意思 觉得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，太复杂了，我希望是—个 希望有用。;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;; 1 or nil= TopLeft
;;; 2= TopCenter
;;; 3= TopRight
;;; 4= MiddleLeft
;;; 5= MiddleCenter
;;; 6= MiddleRight
;;; 7= BottomLeft
;;; 8= BottomCenter
;;; 9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
#Space #Insertion #Object
)
(or #Width (setq #Width 0))
(or *AcadDoc*
(setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ or
(setq #Space (if (or (eq acmodelspace
(vla-get-activespace *AcadDoc*)
) ;_ eq
(eq :vlax-true (vla-get-mspace *AcadDoc*))
) ;_ or
(vla-get-modelspace *AcadDoc*)
(vla-get-paperspace *AcadDoc*)
) ;_ if
#Insertion (cond
((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
((eq (type #InsertionPoint) 'variant) #InsertionPoint)
(T nil)
) ;_ cond
) ;_ setq
;; create MText object
(setq #Object (vla-addmtext #Space #Insertion #Width #String))
;; change layer, if applicable
(and #Layer
(tblsearch "layer" #Layer)
(vla-put-layer #Object #Layer)
) ;_ and
;; change justification & match insertion point with new justification
(cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
(vla-put-attachmentpoint #Object #Justification)
(vla-move #Object
(vla-get-InsertionPoint #Object)
#Insertion
) ;_ vla-move
)
) ;_ cond
#Object
) ;_ 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 static/image/common/back.gif
大大好，小弟有个思路不知是否可行：
首先，替换组码肯定是行不通了，那么只好创建了。
通过组码表找到需 ...
这是我昨天写的，有点问题
;;单行文字变多行文字
(defun text2mtext (e / EN ILIST TENT)
(setq en (entget e))
(Setq TENT '((0 . "MTEXT")(100 . "AcDbMText")))
(ForEach INUM '(7 8 10 40 41 71 72 1 7 11 42 43 50 73)
(If (Setq ILIST (Assoc INUM en))
(Setq TENT (Cons ILIST TENT))
)
)
(entdel e)
(EntMake (Reverse TENT))
)