设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 多行文本转成单行的多行文本?
返回列表 发新帖
查看: 2143|回复: 8

[讨论] 多行文本转成单行的多行文本?

[复制链接]
lucas_3333
发表于 2014-7-26 08:57:12 | 显示全部楼层 |阅读模式
网上找到一个程序，怎么会丢行？
  2. ;Explode MText
  3. ;Explodes Mtext into single lines of mtext
  4. ;Written by: cmwade77 @ theswamp.org - July 2014
  5. ;Bug: Currenlty Only works on the first two lines of mtext
  6. ;Work Around: Repeat use until all lines are exploded
  7. (defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text pt1 style ct OldCt Width txtobj Layer LineCt Pt2 LSpace color)
  8.   (vl-load-com)
  9.   (setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
  10.         *modelspace*  (vla-get-ModelSpace *thisdrawing*)
  11.       *paperspace*  (vla-get-PaperSpace *thisdrawing*)
  12.   )
  13.   (setq Ent (nentselp "\rSelect text to explode: "))
  14.   (setq Object (vlax-ename->vla-object (car Ent))
  15.       ObjectType (vla-get-ObjectName Object)
  16.   )
  17.   (if (wcmatch ObjectType "*Text*")
  18.     (progn
  19.       (setq Text (vla-get-textstring Object)
  20.           pt1 (vla-get-InsertionPoint Object)
  21.           style (vla-get-StyleName Object)
  22.           Width (vla-get-width Object)
  23.           Layer (vla-get-Layer Object)
  24.           LSpace (vla-get-LineSpacingDistance Object)
  25.           pt1 (vlax-safearray->list (vlax-variant-value pt1))
  26.           color (vla-get-color Object)
  27.       )
  28.       (vla-delete Object)
  29.       (setq ct 1)
  30.       (setq LineCt 0)
  31.       (setq OldCt 1)
  32.       (while (<= ct (strlen Text))
  33.         (if (= (substr Text ct 2) "\\P")
  34.           (progn
  35.             (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1)))
  36.             (setq NewText (substr Text OldCt (+ (- (- ct 1) OldCt) 1))
  37.                 OldCt (+ ct 2)
  38.                 LineCt (+ LineCt 1)               
  39.             )   
  40.             (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
  41.               (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
  42.               (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
  43.             )
  44.             (vla-put-StyleName txtobj Style)
  45.             (vla-put-layer txtObj Layer)
  46.             (vla-put-color txtObj color)
  47.           )
  48.         )
  49.         (setq ct (+ ct 1))
  50.       )
  51.     )
  52.   )
  53. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

edata
发表于 2014-7-26 11:37:42 | 显示全部楼层
  1. ;Explode MText
  2. ;Explodes Mtext into single lines of mtext
  3. ;Written by: cmwade77 @ theswamp.org - July 2014
  4. ;Bug: Currenlty Only works on the first two lines of mtext
  5. ;Work Around: Repeat use until all lines are exploded
  6. ;The bug modfiy by: edata  @mjtd.com 2014-7-26

  8. (defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text NEWTEXT pt1 style textlst  Width txtobj Layer LineCt Pt2 LSpace color)
  9.   (vl-load-com)
  10.   (setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
  11.         *modelspace*  (vla-get-ModelSpace *thisdrawing*)
  12.       *paperspace*  (vla-get-PaperSpace *thisdrawing*)
  13.   )
  14.   (setq Ent (nentselp "\rSelect text to explode: "))
  15.   (setq Object (vlax-ename->vla-object (car Ent))
  16.       ObjectType (vla-get-ObjectName Object)
  17.   )
  18.   (if (wcmatch ObjectType "*Text*")
  19.     (progn
  20.       (setq Text (vla-get-textstring Object)
  21.           pt1 (vla-get-InsertionPoint Object)
  22.           style (vla-get-StyleName Object)
  23.           Width (vla-get-width Object)
  24.           Layer (vla-get-Layer Object)
  25.           LSpace (vla-get-LineSpacingDistance Object)
  26.           pt1 (vlax-safearray->list (vlax-variant-value pt1))
  27.           color (vla-get-color Object)
  28.       )
  29.       (vla-delete Object)      
  30.       (setq LineCt 0)            
  31.       (setq textlst(parse12 Text "\\P"))      
  32.       (while (setq NewText(car textlst))
  33.         (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1))
  34.               LineCt (+ LineCt 1))
  35.         (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
  36.               (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
  37.               (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
  38.             )
  39.             (vla-put-StyleName txtobj Style)
  40.             (vla-put-layer txtObj Layer)
  41.             (vla-put-color txtObj color)
  42.         (setq textlst(cdr textlst))
  43.         )
  44.     )
  45.   )
  46. )
  47. ;;string delimiter
  48. ;;code By st788796
  49. (defun parse12 (str delimiter / POST STRL STRLST)
  50.   (setq strl (strlen delimiter))
  51.   (while (vl-string-search delimiter str)
  52.     (setq post (vl-string-search delimiter str))
  53.     (setq strlst (append strlst (list (substr str 1 post))))
  54.     (setq str (substr str (+ post (1+ strl))))
  55.   )
  56.   (vl-remove "" (append strlst (list str)))
  57. )

评分

参与人数 1明经币 +1 收起 理由
lucas_3333 + 1 谢谢Ｅ大，心中除了感激还是感激！

查看全部评分

回复 支持 反对

使用道具 举报

lucas_3333
 楼主| 发表于 2014-7-26 12:10:46 | 显示全部楼层
edata 发表于 2014-7-26 11:37

Ｅ大，谢谢，其实我也用不上这个程序，只是在看到CAB在求助这样的程序，觉得奇怪，以他的能力应该能解决此类问题，所以把此问题拿到这里探讨，谢谢您的无私帮助！
回复 支持 反对

使用道具 举报

edata
发表于 2014-7-26 12:24:53 | 显示全部楼层
lucas_3333 发表于 2014-7-26 12:10
Ｅ大，谢谢，其实我也用不上这个程序，只是在看到CAB在求助这样的程序，觉得奇怪，以他的能力应该能解决此 ...

这个仅仅适用于换行符效果。
对于CAB的问题，也不能做到很好的解决。
回复 支持 反对

使用道具 举报

lucas_3333
 楼主| 发表于 2014-7-26 12:51:35 | 显示全部楼层
edata 发表于 2014-7-26 12:24
这个仅仅适用于换行符效果。
对于CAB的问题，也不能做到很好的解决。

哈哈，难怪，看来他的问题是有点复杂！
回复 支持 反对

使用道具 举报

edata
发表于 2014-7-26 13:02:25 | 显示全部楼层
他这个要全局分析所有转义代码，分析空行。转义代码控制字符显示高低等功能，如果仅仅分割换行符号，没有加上前面的转义字符，是不完整的。对于空行，也需要特殊处理，使之符号行距要求，如果有自动换行的，那么更糟糕。
回复 支持 反对

使用道具 举报

lucas_3333
 楼主| 发表于 2014-7-26 13:13:10 | 显示全部楼层
edata 发表于 2014-7-26 13:02
他这个要全局分析所有转义代码，分析空行。转义代码控制字符显示高低等功能，如果仅仅分割换行符号，没有加 ...

嗯，您的修改应该还是可以帮助一些人，比如cmwade77，哈哈，高手提出的问题，只有等待高手解决了。
回复 支持 反对

使用道具 举报

edata
发表于 2014-7-26 15:42:56 | 显示全部楼层
做到基本行距
格式分析。。。没时间。
  1. ;Explode MText
  2. ;Explodes Mtext into single lines of mtext
  3. ;Written by: cmwade77 @ theswamp.org - July 2014
  4. ;Bug: Currenlty Only works on the first two lines of mtext
  5. ;Work Around: Repeat use until all lines are exploded
  6. ;The bug modify by: edata  @mjtd.com 2014-7-26

  8. (defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text NEWTEXT pt1 style textlst  Width txtobj Layer LineCt Pt2 LSpace color)
  9.   (vl-load-com)
  10.   (setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
  11.         *modelspace*  (vla-get-ModelSpace *thisdrawing*)
  12.       *paperspace*  (vla-get-PaperSpace *thisdrawing*)
  13.   )
  14.   (setq Ent (nentselp "\rSelect text to explode: "))
  15.   (setq Object (vlax-ename->vla-object (car Ent))
  16.       ObjectType (vla-get-ObjectName Object)
  17.   )
  18.   (if (wcmatch ObjectType "*Text*")
  19.     (progn
  20.       (setq Text (vla-get-textstring Object)
  21.           pt1 (vla-get-InsertionPoint Object)
  22.           style (vla-get-StyleName Object)
  23.           Width (vla-get-width Object)
  24.           Layer (vla-get-Layer Object)
  25.           LSpace (vla-get-LineSpacingDistance Object)
  26.           pt1 (vlax-safearray->list (vlax-variant-value pt1))
  27.           color (vla-get-color Object)
  28.       )
  29.       (vla-delete Object)      
  30.       (setq LineCt 0)            
  31.       (setq textlst(parse12 Text "\\P"))
  32.       (print textlst)
  33.       (while (setq NewText(car textlst))
  34.         (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1))
  35.               LineCt (+ LineCt 1))
  36.         (if (or (/= NewText "")(/= NewText " "))
  37.           (progn
  38.             (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
  39.               (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
  40.               (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
  41.               )
  42.             (vla-put-StyleName txtobj Style)
  43.             (vla-put-layer txtObj Layer)
  44.             (vla-put-color txtObj color)
  45.             )
  46.           )
  47.         (setq textlst(cdr textlst))
  48.         )
  49.     )
  50.   )
  51. )
  52. ;;string delimiter
  53. ;;code By st788796
  54. (defun parse12 (str delimiter / POST STRL STRLST)
  55.   (setq strl (strlen delimiter))
  56.   (while (vl-string-search delimiter str)
  57.     (setq post (vl-string-search delimiter str))
  58.     (setq strlst (append strlst (list (substr str 1 post))))
  59.     (setq str (substr str (+ post (1+ strl))))
  60.   )
  61.   (append strlst (list str))
  62.   ;(vl-remove "" (append strlst (list str)))
  63. )

评分

参与人数 1明经币 +1 收起 理由
lucas_3333 + 1 赞一个!

查看全部评分

回复 支持 反对

使用道具 举报

lucas_3333
 楼主| 发表于 2014-7-26 15:46:02 | 显示全部楼层
edata 发表于 2014-7-26 15:42
做到基本行距
格式分析。。。没时间。

Ｅ大，不要花时间在这上面了，
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2025-5-24 09:33 , Processed in 0.164915 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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