lucas_3333 发表于 2014-7-26 08:57:12

多行文本转成单行的多行文本?

网上找到一个程序，怎么会丢行？;Explode MText
;Explodes Mtext into single lines of mtext
;Written by: cmwade77 @ theswamp.org - July 2014
;Bug: Currenlty Only works on the first two lines of mtext
;Work Around: Repeat use until all lines are exploded
(defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text pt1 style ct OldCt Width txtobj Layer LineCt Pt2 LSpace color)
(vl-load-com)
(setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
      *modelspace*(vla-get-ModelSpace *thisdrawing*)
      *paperspace*(vla-get-PaperSpace *thisdrawing*)
)
(setq Ent (nentselp "\rSelect text to explode: "))
(setq Object (vlax-ename->vla-object (car Ent))
      ObjectType (vla-get-ObjectName Object)
)
(if (wcmatch ObjectType "*Text*")
    (progn
      (setq Text (vla-get-textstring Object)
          pt1 (vla-get-InsertionPoint Object)
          style (vla-get-StyleName Object)
          Width (vla-get-width Object)
          Layer (vla-get-Layer Object)
          LSpace (vla-get-LineSpacingDistance Object)
          pt1 (vlax-safearray->list (vlax-variant-value pt1))
          color (vla-get-color Object)
      )
      (vla-delete Object)
      (setq ct 1)
      (setq LineCt 0)
      (setq OldCt 1)
      (while (<= ct (strlen Text))
      (if (= (substr Text ct 2) "\\P")
          (progn
            (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1)))
            (setq NewText (substr Text OldCt (+ (- (- ct 1) OldCt) 1))
                OldCt (+ ct 2)
                LineCt (+ LineCt 1)               
            )   
            (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
            (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
            (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
            )
            (vla-put-StyleName txtobj Style)
            (vla-put-layer txtObj Layer)
            (vla-put-color txtObj color)
          )
      )
      (setq ct (+ ct 1))
      )
    )
)
)

edata 发表于 2014-7-26 11:37:42

;Explode MText
;Explodes Mtext into single lines of mtext
;Written by: cmwade77 @ theswamp.org - July 2014
;Bug: Currenlty Only works on the first two lines of mtext
;Work Around: Repeat use until all lines are exploded
;The bug modfiy by: edata@mjtd.com 2014-7-26

(defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text NEWTEXT pt1 style textlstWidth txtobj Layer LineCt Pt2 LSpace color)
(vl-load-com)
(setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
      *modelspace*(vla-get-ModelSpace *thisdrawing*)
      *paperspace*(vla-get-PaperSpace *thisdrawing*)
)
(setq Ent (nentselp "\rSelect text to explode: "))
(setq Object (vlax-ename->vla-object (car Ent))
      ObjectType (vla-get-ObjectName Object)
)
(if (wcmatch ObjectType "*Text*")
    (progn
      (setq Text (vla-get-textstring Object)
          pt1 (vla-get-InsertionPoint Object)
          style (vla-get-StyleName Object)
          Width (vla-get-width Object)
          Layer (vla-get-Layer Object)
          LSpace (vla-get-LineSpacingDistance Object)
          pt1 (vlax-safearray->list (vlax-variant-value pt1))
          color (vla-get-color Object)
      )
      (vla-delete Object)      
      (setq LineCt 0)            
      (setq textlst(parse12 Text "\\P"))      
      (while (setq NewText(car textlst))
        (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1))
              LineCt (+ LineCt 1))
        (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
            (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
            (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
            )
            (vla-put-StyleName txtobj Style)
            (vla-put-layer txtObj Layer)
            (vla-put-color txtObj color)
        (setq textlst(cdr textlst))
        )
    )
)
)
;;string delimiter
;;code By st788796
(defun parse12 (str delimiter / POST STRL STRLST)
(setq strl (strlen delimiter))
(while (vl-string-search delimiter str)
    (setq post (vl-string-search delimiter str))
    (setq strlst (append strlst (list (substr str 1 post))))
    (setq str (substr str (+ post (1+ strl))))
)
(vl-remove "" (append strlst (list str)))
)

lucas_3333 发表于 2014-7-26 12:10:46

edata 发表于 2014-7-26 11:37 static/image/common/back.gif


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

edata 发表于 2014-7-26 12:24:53

lucas_3333 发表于 2014-7-26 12:10 static/image/common/back.gif
Ｅ大，谢谢，其实我也用不上这个程序，只是在看到CAB在求助这样的程序，觉得奇怪，以他的能力应该能解决此 ...

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

lucas_3333 发表于 2014-7-26 12:51:35

edata 发表于 2014-7-26 12:24 static/image/common/back.gif
这个仅仅适用于换行符效果。
对于CAB的问题，也不能做到很好的解决。

哈哈，难怪，看来他的问题是有点复杂！

edata 发表于 2014-7-26 13:02:25

他这个要全局分析所有转义代码，分析空行。转义代码控制字符显示高低等功能，如果仅仅分割换行符号，没有加上前面的转义字符，是不完整的。对于空行，也需要特殊处理，使之符号行距要求，如果有自动换行的，那么更糟糕。

lucas_3333 发表于 2014-7-26 13:13:10

edata 发表于 2014-7-26 13:02 static/image/common/back.gif
他这个要全局分析所有转义代码，分析空行。转义代码控制字符显示高低等功能，如果仅仅分割换行符号，没有加 ...

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

edata 发表于 2014-7-26 15:42:56

做到基本行距
格式分析。。。没时间。
;Explode MText
;Explodes Mtext into single lines of mtext
;Written by: cmwade77 @ theswamp.org - July 2014
;Bug: Currenlty Only works on the first two lines of mtext
;Work Around: Repeat use until all lines are exploded
;The bug modify by: edata@mjtd.com 2014-7-26

(defun c:explodemtext (/ *thisdrawing* *modelspace* *paperspace* Ent Object ObjectType Text NEWTEXT pt1 style textlstWidth txtobj Layer LineCt Pt2 LSpace color)
(vl-load-com)
(setq *thisdrawing* (vla-get-activedocument (vlax-get-acad-object))
      *modelspace*(vla-get-ModelSpace *thisdrawing*)
      *paperspace*(vla-get-PaperSpace *thisdrawing*)
)
(setq Ent (nentselp "\rSelect text to explode: "))
(setq Object (vlax-ename->vla-object (car Ent))
      ObjectType (vla-get-ObjectName Object)
)
(if (wcmatch ObjectType "*Text*")
    (progn
      (setq Text (vla-get-textstring Object)
          pt1 (vla-get-InsertionPoint Object)
          style (vla-get-StyleName Object)
          Width (vla-get-width Object)
          Layer (vla-get-Layer Object)
          LSpace (vla-get-LineSpacingDistance Object)
          pt1 (vlax-safearray->list (vlax-variant-value pt1))
          color (vla-get-color Object)
      )
      (vla-delete Object)      
      (setq LineCt 0)            
      (setq textlst(parse12 Text "\\P"))
      (print textlst)
      (while (setq NewText(car textlst))
      (setq pt2 (vlax-3d-point (nth 0 Pt1) (- (nth 1 Pt1) (* LineCt LSPace)) (nth 2 Pt1))
            LineCt (+ LineCt 1))
        (if (or (/= NewText "")(/= NewText " "))
          (progn
          (if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
              (setq txtobj (vla-AddMtext *modelspace* pt2 width NewText))
              (setq txtobj (vla-AddMtext *paperspace* pt2 width NewText))
              )
          (vla-put-StyleName txtobj Style)
            (vla-put-layer txtObj Layer)
            (vla-put-color txtObj color)
          )
          )
        (setq textlst(cdr textlst))
      )
    )
)
)
;;string delimiter
;;code By st788796
(defun parse12 (str delimiter / POST STRL STRLST)
(setq strl (strlen delimiter))
(while (vl-string-search delimiter str)
    (setq post (vl-string-search delimiter str))
    (setq strlst (append strlst (list (substr str 1 post))))
    (setq str (substr str (+ post (1+ strl))))
)
(append strlst (list str))
;(vl-remove "" (append strlst (list str)))
)

lucas_3333 发表于 2014-7-26 15:46:02

edata 发表于 2014-7-26 15:42 static/image/common/back.gif
做到基本行距
格式分析。。。没时间。

Ｅ大，不要花时间在这上面了，
页: [1]
查看完整版本: 多行文本转成单行的多行文本?