明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 3441|回复: 20

多个多行文字合并源码

[复制链接]
发表于 2012-8-4 14:04 | 显示全部楼层 |阅读模式
本帖最后由 piaoyun 于 2012-8-4 15:02 编辑

参考论坛上其他人的单行文字合并改的
;;合并多个多行文字


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2012-8-4 15:49 | 显示全部楼层
本帖最后由 sachindkini 于 2012-8-4 15:55 编辑
[code="lisp]
  1. Text2MTextV2-0.lsp © 2012 Lee Mac
  2. DarkLightVLIDE
  3. ;;---------------------=={  Text 2 MText Upgraded  }==---------------------------;;
  4. ;;                                                                               ;;
  5. ;;  Similar to the Txt2MTxt Express Tools function, but allows the user          ;;
  6. ;;  additional control over where the text is placed in the resultant MText.     ;;
  7. ;;                                                                               ;;
  8. ;;  The user can pick MText or DText, positioning such text using one of two     ;;
  9. ;;  modes: "New Line" or "Same Line". The Modes can be switched by pressing      ;;
  10. ;;  Space between picks.                                                         ;;
  11. ;;                                                                               ;;
  12. ;;  The user can also hold shift and pick text to keep the original text in      ;;
  13. ;;  place, and press "u" between picks to undo the last text pick.               ;;
  14. ;;                                                                               ;;
  15. ;;-------------------------------------------------------------------------------;;
  16. ;;                                                                               ;;
  17. ;;  FUNCTION SYNTAX:  T2M                                                        ;;
  18. ;;                                                                               ;;
  19. ;;  Notes:-                                                                      ;;
  20. ;;  --------                                                                     ;;
  21. ;;  Shift-click functionality requires the user to have Express Tools installed. ;;
  22. ;;                                                                               ;;
  23. ;;-------------------------------------------------------------------------------;;
  24. ;;                                                                               ;;
  25. ;;  Author: Lee Mac, Copyright © September 2009 - www.lee-mac.com                ;;
  26. ;;                                                                               ;;
  27. ;;-------------------------------------------------------------------------------;;
  28. ;;                                                                               ;;
  29. ;;  Version:                                                                     ;;
  30. ;;                                                                               ;;
  31. ;;  1.0:  27/09/2009  -  First Release                                           ;;
  32. ;;-------------------------------------------------------------------------------;;
  33. ;;  1.1:  29/09/2009  -  Minor Bug Fixes                                         ;;
  34. ;;-------------------------------------------------------------------------------;;
  35. ;;  1.2:  29/09/2009  -  Fixed Alignment Bug                                     ;;
  36. ;;                    -  Added Code to match Height                              ;;
  37. ;;-------------------------------------------------------------------------------;;
  38. ;;  1.3:  01/10/2009  -  Added option to Copy Text.                              ;;
  39. ;;-------------------------------------------------------------------------------;;
  40. ;;  1.4:  01/10/2009  -  Added option to Undo Last text selection                ;;
  41. ;;-------------------------------------------------------------------------------;;
  42. ;;  1.5:  30/03/2010  -  Modified code to allow for mis-click.                   ;;
  43. ;;                    -  Updated UndoMarks.                                      ;;
  44. ;;-------------------------------------------------------------------------------;;
  45. ;;  1.6:  15/04/2010  -  MText objects now have correct width.                   ;;
  46. ;;                    -  Accounted for %%U symbol.                               ;;
  47. ;;-------------------------------------------------------------------------------;;
  48. ;;  1.7:  16/04/2010  -  Fixed %%U bug.                                          ;;
  49. ;;                    -  Trimmed Spaces when in 'Same Line' mode.                ;;
  50. ;;                    -  Fixed Width when Undo is used.                          ;;
  51. ;;                    -  Allowed Shift-Click to keep first text object selected. ;;
  52. ;;-------------------------------------------------------------------------------;;
  53. ;;  1.8:  10/05/2010  -  Allowed for UCS variations.                             ;;
  54. ;;                    -  Matched initial text rotation.                          ;;
  55. ;;-------------------------------------------------------------------------------;;
  56. ;;  1.9:  21/05/2010  -  Added ability to use SelectionSet to select text.       ;;
  57. ;;-------------------------------------------------------------------------------;;
  58. ;;  2.0:  07/06/2010  -  Fixed offset from cursor with rotated text.             ;;
  59. ;;-------------------------------------------------------------------------------;;

  60. (defun c:t2m ( /  ;; -={ Local Functions }=-

  61.                    *error* align_Mt Get_MTOffset_pt
  62.                    GetTextWidth ReplaceUnderline

  63.                   ;; -={ Local Variables }=-

  64.                   CODE
  65.                   DATA DOC
  66.                   ELST ENT ET
  67.                   FORMFLAG
  68.                   GRDATA
  69.                   LHGT LLST
  70.                   MLST MSG
  71.                   NOBJ NSTR
  72.                   OBJ
  73.                   SHFT SPC
  74.                   TENT TOBJ TEXTSS
  75.                   UFLAG UNDER
  76.                   WLST
  77.               
  78.                   ;; -={ Global Variables }=-

  79.                   ; *T2M_mode*  ~  Mode for line addition
  80. )
  81.   

  82. ;     --=={ Sub Functions  }==--      ;

  83.   ;; -={ Error Handler }=-

  84.   (defun *error* (err)
  85.     (and uFlag (vla-EndUndoMark doc))
  86.     (and tObj  (not (vlax-erased-p tObj)) (vla-delete tObj))
  87.    
  88.     (if eLst (mapcar (function entdel)
  89.                (vl-remove-if (function null) eLst)))
  90.    
  91.     (or (wcmatch (strcase err) "*BREAK,*CANCEL*,*EXIT*")
  92.         (princ (strcat "\n** Error: " err " **")))
  93.     (princ))

  94.   
  95. ;;-------------------------------------------------------------------------------;;
  96.   

  97.   (defun align_Mt (obj / al)
  98.     (cond (  (eq "AcDbMText" (vla-get-ObjectName obj))
  99.              (vla-get-AttachmentPoint obj))

  100.           (  (eq "AcDbText" (vla-get-ObjectName obj))
  101.              (setq al (vla-get-Alignment obj))

  102.              (cond (  (<= 0 al 2) (1+ al))
  103.                    (  (<= 3 al 5) 1)
  104.                    (t (- al 5))))))
  105.   

  106. ;;-------------------------------------------------------------------------------;;
  107.   

  108.   (defun Get_MTOffset_pt ( obj pt / miP maP al )
  109.     (vla-getBoundingBox obj 'miP 'maP)
  110.     (setq miP (vlax-safearray->list miP)
  111.           maP (vlax-safearray->list maP))

  112.     (setq al (vla-get-AttachmentPoint obj) r (vla-get-rotation obj))

  113.     (cond (  (or (eq acAttachmentPointTopLeft   al)
  114.                  (eq acAttachmentPointTopCenter al)
  115.                  (eq acAttachmentPointTopRight  al))
  116.            
  117.              (polar pt (- r (/ pi 2.)) (vla-get-Height obj)))

  118.           (  (or (eq acAttachmentPointMiddleLeft   al)
  119.                  (eq acAttachmentPointMiddleCenter al)
  120.                  (eq acAttachmentPointMiddleRight  al))
  121.            
  122.              (polar pt (- r (/ pi 2.)) (+ (vla-get-Height obj)
  123.                                           (/ (- (cadr maP) (cadr miP)) 2.))))
  124.   
  125.           (  (or (eq acAttachmentPointBottomLeft   al)
  126.                  (eq acAttachmentPointBottomCenter al)
  127.                  (eq acAttachmentPointBottomRight  al))
  128.            
  129.              (polar pt (- r (/ pi 2.)) (+ (vla-get-Height obj)
  130.                                           (- (cadr maP) (cadr miP)))))))
  131.   

  132. ;;-------------------------------------------------------------------------------;;
  133.   

  134.   (defun GetTextWidth (obj / tBox eLst)
  135.     (cond (  (eq "AcDbText" (vla-get-objectname obj))

  136.              (setq eLst (entget  (vlax-vla-object->ename obj))
  137.                    tBox (textbox
  138.                           (subst
  139.                             (cons 1 (strcat "..." (cdr (assoc 1 eLst))))
  140.                               (assoc 1 eLst) eLst)))

  141.              (- (caadr tBox) (caar tBox)))

  142.           (  (vla-get-Width obj))))
  143.   

  144. ;;-------------------------------------------------------------------------------;;
  145.   

  146.   (defun ReplaceUnderline (str / i under)
  147.     (if (vl-string-search "%%U" (strcase Str))
  148.       (progn
  149.         (while (and (< i (strlen Str))
  150.                     (setq i (vl-string-search "%%U" (strcase Str) i)))
  151.           (if under
  152.             (setq Str (strcat (substr Str 1 i) "\\l" (substr Str (+ i 4))) i (+ i 4) under nil)
  153.             (setq Str (strcat (substr Str 1 i) "\\L" (substr Str (+ i 4))) i (+ i 4) under t  )))
  154.         
  155.         (if under (setq str (strcat str "\\l")))))
  156.    
  157.     str)
  158.   

  159. ;     --=={ Main Function  }==--


  160.   (setq doc (vla-get-ActiveDocument
  161.               (vlax-get-acad-object))

  162.         spc (if (or (eq AcModelSpace (vla-get-activespace doc))
  163.                     (eq :vlax-true   (vla-get-MSpace doc)))

  164.               (vla-get-modelspace doc)
  165.               (vla-get-paperspace doc)))
  166.   
  167.   (setq Et
  168.       (and (vl-position "acetutil.arx" (arx))
  169.            (not
  170.              (vl-catch-all-error-p
  171.                (vl-catch-all-apply
  172.                  (function (lambda nil (acet-sys-shift-down))))))))

  173.   (or *T2M_Mode* (setq *T2M_Mode* 0))
  174.   (setq mLst '("New Line " "Same Line"))

  175.   (while
  176.     (progn
  177.       (setq ent (car (entsel "\nSelect Text/MText [Shift-Click keep original]: ")))
  178.       (and et (setq shft (acet-sys-shift-down)))
  179.       
  180.       (cond (  (not ent)
  181.                (princ "\n** Nothing Selected **"))
  182.             
  183.             (  (not (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT"))
  184.                (princ "\n** Object is not Text **")))))

  185.   (setq uFlag (not (vla-StartUndoMark doc)))

  186.   (setq tObj
  187.     (vla-AddMText spc
  188.       
  189.       (vla-get-InsertionPoint
  190.         (setq obj (vlax-ename->vla-object ent))) (GetTextWidth obj)
  191.       
  192.           (ReplaceUnderline (vla-get-TextString obj))))

  193.   (foreach p '(InsertionPoint Layer Color StyleName Height)
  194.     (vlax-put-property tObj p
  195.       (vlax-get-property obj p)))

  196.   (vla-put-rotation tObj
  197.     (if (eq "AcDbText" (vla-get-ObjectName obj))
  198.       (- (vla-get-rotation obj)
  199.          (angle '(0. 0. 0.)
  200.            (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t))))
  201.       (vla-get-rotation obj)))
  202.   
  203.   (vla-put-AttachmentPoint tObj (align_Mt obj))

  204.   (or (and shft
  205.            (setq eLst (cons nil eLst)))
  206.       (and (entdel ent)
  207.            (setq eLst (cons ent eLst))))

  208.   (princ (eval (setq msg '(strcat "\n~¤~  Current Mode: " (nth *T2M_mode* mLst) " ~¤~   [Space to Change]"
  209.                                   "\n~¤~ Select Text to Convert [Shift-Click keep original] [Undo]  ~¤~"))))

  210.   (while
  211.     (progn
  212.       (setq grdata (grread 't 15 2)
  213.             code   (car grdata) data (cadr grdata))

  214.       (cond (  (and (= 5 code) (listp data))

  215.                (vla-put-InsertionPoint tObj
  216.                  (vlax-3D-point
  217.                    (Get_MTOffset_pt tObj (trans data 1 0)))) t)

  218.             (  (and (= 3 code) (listp data))

  219.                (if (and (setq tEnt (car (nentselp data)))
  220.                         (wcmatch (cdr (assoc 0 (entget tEnt))) "*TEXT"))
  221.                  
  222.                  (AddtoMTextSelection tEnt)

  223.                  (progn
  224.                    (vla-put-Visible tObj :vlax-false)

  225.                    (if (setq textss (GetSelectionSet "\nPick Corner Point: " data '((0 . "TEXT,MTEXT"))))
  226.                      (
  227.                        (lambda ( i )
  228.                          (while (setq e (ssname textss (setq i (1+ i))))
  229.                            (AddtoMTextSelection e)
  230.                          )
  231.                          (princ (eval msg))
  232.                        )
  233.                        -1
  234.                      )
  235.                      (princ (strcat "\n** No Text/MText Selected **" (eval msg)))
  236.                    )
  237.                   
  238.                    (vla-put-Visible tObj :vlax-true) t
  239.                  )
  240.                )
  241.             )

  242.             (  (= 25 code) nil)

  243.             (  (= 2 code)

  244.                (cond (  (= 13 data) nil)
  245.                      
  246.                      (  (= 32 data)
  247.                      
  248.                         (setq *T2M_mode* (- 1 *T2M_mode*))
  249.                         (princ (eval msg)))
  250.                      
  251.                      (  (vl-position data '(85 117))
  252.                      
  253.                         (if (< 1 (length eLst))
  254.                           (progn
  255.                            
  256.                             (vla-put-TextString tObj
  257.                               (substr (vla-get-TextString tObj) 1 (car lLst)))

  258.                             (vla-put-Width tObj (car wLst))
  259.                            
  260.                             (if (car eLst) (entdel (car eLst)))
  261.                             (setq eLst (cdr eLst) lLst (cdr lLst) wLst (cdr wLst)) t)
  262.                           
  263.                           (progn
  264.                             (princ "\n** Nothing to Undo **")
  265.                             (princ (eval msg)))))                           
  266.                            
  267.                      (t )))

  268.             (t ))))

  269.   (setq uFlag (vla-EndUndoMark doc))
  270.   (princ))

  271. (defun AddtoMTextSelection ( tEnt / nStr nObj formflag )
  272.   (setq lLst (cons (strlen (vla-get-TextString tObj)) lLst)
  273.         wLst (cons (vla-get-Width tObj) wLst))
  274.   
  275.   (setq nStr
  276.      (vla-get-TextString
  277.        (setq nObj
  278.           (vlax-ename->vla-object tEnt))) formflag nil)
  279.   
  280.   (vla-put-Width tObj
  281.     ((if (= *T2M_mode* 1) + max)
  282.       (vla-get-Width tObj) (GetTextWidth nObj)))
  283.   
  284.   (if (not (or (eq (vla-get-Color nObj) (vla-get-Color tObj))
  285.              (vl-position (vla-get-Color nObj) '(255 0))))
  286.    
  287.     (setq nStr (strcat "\\C" (itoa (vla-get-Color nObj)) ";" nStr) formflag t))
  288.   
  289.   (setq nStr (ReplaceUnderline nStr))
  290.   
  291.   (if (not (or (eq (vla-get-Height nObj) (vla-get-Height tObj))
  292.              (and lHgt (eq (vla-get-Height nObj) lHgt))))
  293.    
  294.     (setq nStr (strcat "\\H" (rtos (/ (float (vla-get-Height nObj))
  295.                                       (cond (lHgt) ((vla-get-Height tObj)))) 2 2)  "x;" nStr)
  296.       lHgt (vla-get-Height nObj) formflag t))
  297.   
  298.   (if (not (eq (vla-get-StyleName nObj) (vla-get-StyleName tObj)))
  299.     (setq nStr
  300.        (strcat "\\F" (vla-get-fontfile
  301.                        (vla-item
  302.                          (vla-get-TextStyles doc)
  303.                          (vla-get-StyleName nObj))) ";" nStr) formflag t))
  304.   
  305.   (if formflag (setq nStr (strcat "{" nStr "}")))
  306.   
  307.   (vla-put-TextString tObj
  308.     (strcat
  309.       (vla-get-TextString tObj)
  310.       (if (zerop *T2M_mode*)
  311.         (strcat "\\P" nStr)
  312.         (strcat " "  (vl-string-left-trim (chr 32) nStr)))))
  313.   
  314.   (vla-update tObj)
  315.   (or (and et (acet-sys-shift-down)
  316.         (setq eLst (cons nil eLst)))
  317.     (and (entdel tEnt)
  318.       (setq eLst (cons tEnt eLst)))) t)


  319. (defun GetSelectionSet ( str pt filter / gr data pt1 pt2 lst )
  320.   (princ str)

  321.   (while (and (= 5 (car (setq gr (grread t 13 0)))) (listp (setq data (cadr gr))))
  322.     (redraw)

  323.     (setq pt1 (list (car data) (cadr pt) (caddr data))
  324.           pt2 (list (car pt) (cadr data) (caddr data)))

  325.     (grvecs
  326.       (setq lst
  327.         (list
  328.           (if (minusp (- (car data) (car pt))) -30 30)
  329.           pt pt1 pt pt2 pt1 data pt2 data
  330.         )
  331.       )
  332.     )
  333.   )

  334.   (redraw)

  335.   (ssget (if (minusp (car lst)) "_C" "_W") pt data filter)
  336. )

  337. (vl-load-com)
  338. (princ "\n:: Text2MText.lsp | Version 2.0 | © Lee Mac 2009 www.lee-mac.com ::")
  339. (princ "\n:: Type "T2M" to Invoke ::")
  340. (princ)
[/code]

点评

老外啊 不错哦  发表于 2015-7-6 17:29

评分

参与人数 1明经币 +1 金钱 +50 收起 理由
jicqj + 1 + 50 很给力!

查看全部评分

发表于 2012-8-4 20:26 | 显示全部楼层
学习~~
发表于 2012-8-5 12:19 | 显示全部楼层
收藏了 谢谢sachindkini 和楼主piaoyun
发表于 2012-8-6 15:06 | 显示全部楼层
jicqj 发表于 2012-8-5 12:19
收藏了 谢谢sachindkini 和楼主piaoyun

dear sir,
u r welcome
but this code not written me.
lee mac is written this code
please visit this site more autolisp program & it's free of cost

LeeMac
发表于 2012-8-10 22:16 | 显示全部楼层
sachindkini 发表于 2012-8-6 15:06
dear sir,
u r welcome
but this code not written me.

我的英文水平不高 虽然看的懂你说的 但是要去看那个网址  还是有点晕 呵呵
发表于 2012-11-21 08:50 | 显示全部楼层
好程序,学习啦~
发表于 2013-6-29 10:37 | 显示全部楼层
谢谢楼主的分享!收藏备用。
发表于 2013-7-9 10:29 | 显示全部楼层
很好,赞一个
发表于 2013-7-9 14:30 | 显示全部楼层
谢谢众位坛友代码分享!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-1-21 18:29 , Processed in 0.210111 second(s), 33 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表