求帮助改一段程序.分解文字

wgij007

求帮助改一段程序，出处明经，忘了那个贴了，如有侵犯请提出，必改。能不能改为，打散后，不变图层与颜色。
;;;*****分解文字 程序开始*****
(defun c:tu (/ PtList)
  (setvar "cmdecho" 0)
  (setvar "osmode" 15359)
  (princ "\n★功能：将文字分解为曲线。\n提示：若出现变变换错误，请先将UCS设置为默认。\n")
  (command "undo" "be")
  (princ "\n请选取要分解为曲线的文字：")
  (setq ss (ssget '((0 . "TEXT,MTEXT"))))
  (if (not ss)
    (progn (princ "\n提示：未选中文字，程序退出！\n") (exit))
  )
  (setvar "mirrtext" 1)
  (setvar "osmode" 0)
  (setq i 0)
  (repeat (setq num (sslength ss))
    (setq entnam (ssname ss i))
    (command "zoom" "o" entnam "")
    (setq PixelSize  (getvar "screensize")
                                        ;以像素为单位读取当前视口大小（X 和 Y）
          ViewHeigh  (getvar "viewsize");以图形单位测量当前视口中显示的视图的高度
          ViewCenter (getvar "viewctr")        ;以UCS坐标表示当前视口中的视图的中心
          PtList     (list (list (- (car ViewCenter)
                                    (* 0.5
                                       (* ViewHeigh
                                          (/ (car PixelSize)
                                             (cadr PixelSize)
                                          )
                                       )
                                    )
                                 )
                                 (- (cadr ViewCenter) (* 0.5 ViewHeigh))
                           )                ;视窗区左下角的坐标点
                           (list (+ (car ViewCenter)
                                    (* 0.5
                                       (* ViewHeigh
                                          (/ (car PixelSize)
                                             (cadr PixelSize)
                                          )
                                       )
                                    )
                                 )
                                 (+ (cadr ViewCenter)
                                    (* 0.5 ViewHeigh)
                                 )
                           )                ;视窗区右上角的坐标点
                     )
          LTPoint    (list (caar PtList) ;视窗区左下角的X坐标
                           (cadadr PtList) ;视窗区右上角的Y坐标
                     )
    )
    (setq TempFil (strcat (getenv "Temp") "\\textb.wmf"))
    (command "mirror" entnam "" ViewCenter "@0,1" "y") ;以Y轴镜像
    (command "wmfout" TempFil
             entnam   ""
             "erase"  entnam
             ""              "wmfin"
             TempFil  LTPoint
             "2.0"    ""
             ""
            )
    (command "mirror" (entlast) "" ViewCenter "@0,1" "y") ;以Y轴镜像
    (setq entnam2 (vlax-ename->vla-object (entlast)))
    (setq list1        (vlax-safearray->list
                  (vlax-variant-value (vla-explode entnam2))
                )
          list2        nil
          list3        nil
    )
    (foreach entnam3 list1
      (if (eq (vla-get-ObjectName entnam3) "AcDbLine")
        (progn
          (setq        entnam41 (vlax-curve-getpointatparam
                           entnam3
                           (/ (vlax-curve-getendparam entnam3) 2.0)
                         )
                entnam42 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
          )
          (if (setq entnam43 (assoc entnam42 list3))
            (progn
              (vla-delete entnam3)
              (vla-delete (cadr entnam43))
            )
            (setq list3 (cons (list entnam42 entnam3) list3))
          )
        )
        (progn
          (setq        list2
                 (append (vlax-safearray->list
                           (vlax-variant-value (vla-explode entnam3))
                         )
                         list2
                 )
          )
          (vla-delete entnam3)
        )
      )
    )
    (foreach entnam3 list2
      (if (eq (vla-get-length entnam3) 0.0)
        (if (not (vlax-erased-p entnam3))
          (vla-delete entnam3)
        )
        (progn
          (setq        entnam41 (vlax-curve-getstartpoint entnam3)
                entnam42 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
                entnam41 (vlax-curve-getendpoint entnam3)
                entnam44 (strcat entnam42
                                 (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
                entnam45 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                                 entnam42
                         )
          )
          (if (or (setq entnam43 (assoc entnam44 list3))
                  (setq entnam43 (assoc entnam45 list3))
              )
            (progn
              (if (not (vlax-erased-p entnam3))
                (vla-delete entnam3)
              )
              (if (not (vlax-erased-p (cadr entnam43)))
                (vla-delete (cadr entnam43))
              )
            )
            (setq list3 (cons (list entnam44 entnam3) list3))
          )
        )
      )
    )
    (vla-delete entnam2)
    (setq i (1+ i))
    (command "zoom" "p")
    (vl-file-delete TempFil)
  )
  (setvar "mirrtext" 0)
  (setvar "osmode" 167)
  (command "undo" "e")
  (princ (strcat "\n提示：共将" (itoa num) "个文字对象成功分解为曲线。\n"))
  (princ)
)
;;;*****分解文字 程序结束*****                                                                                                                 

start4444

;;;*****分解文字 程序开始*****
(defun c:tu (/ PtList)
        (setq clayer (getvar "clayer"))
  (setvar "cmdecho" 0)
  (setvar "osmode" 15359)
  (princ "\n★功能：将文字分解为曲线。\n提示：若出现变变换错误，请先将UCS设置为默认。\n")
  (command "undo" "be")
  (princ "\n请选取要分解为曲线的文字：")
  (setq ss (ssget '((0 . "TEXT,MTEXT"))))
  (if (not ss)
    (progn (princ "\n提示：未选中文字，程序退出！\n") (exit))
  )
  (setvar "mirrtext" 1)
  (setvar "osmode" 0)
  (setq i 0)
  (repeat (setq num (sslength ss))
    (setq entnam (ssname ss i))
    (command "zoom" "o" entnam "" "layer" "s" (cdr (assoc 8 (entget entnam))) "")
    (setq PixelSize  (getvar "screensize")
                                        ;以像素为单位读取当前视口大小（X 和 Y）
          ViewHeigh  (getvar "viewsize");以图形单位测量当前视口中显示的视图的高度
          ViewCenter (getvar "viewctr")        ;以UCS坐标表示当前视口中的视图的中心
          PtList     (list (list (- (car ViewCenter)
                                    (* 0.5
                                       (* ViewHeigh
                                          (/ (car PixelSize)
                                             (cadr PixelSize)
                                          )
                                       )
                                    )
                                 )
                                 (- (cadr ViewCenter) (* 0.5 ViewHeigh))
                           )                ;视窗区左下角的坐标点
                           (list (+ (car ViewCenter)
                                    (* 0.5
                                       (* ViewHeigh
                                          (/ (car PixelSize)
                                             (cadr PixelSize)
                                          )
                                       )
                                    )
                                 )
                                 (+ (cadr ViewCenter)
                                    (* 0.5 ViewHeigh)
                                 )
                           )                ;视窗区右上角的坐标点
                     )
          LTPoint    (list (caar PtList) ;视窗区左下角的X坐标
                           (cadadr PtList) ;视窗区右上角的Y坐标
                     )
    )
    (setq TempFil (strcat (getenv "Temp") "\\textb.wmf"))
    (command "mirror" entnam "" ViewCenter "@0,1" "y") ;以Y轴镜像
    (command "wmfout" TempFil
             entnam   ""
             "erase"  entnam
             ""              "wmfin"
             TempFil  LTPoint
             "2.0"    ""
             ""
            )
    (command "mirror" (entlast) "" ViewCenter "@0,1" "y") ;以Y轴镜像
    (setq entnam2 (vlax-ename->vla-object (entlast)))
    (setq list1        (vlax-safearray->list
                  (vlax-variant-value (vla-explode entnam2))
                )
          list2        nil
          list3        nil
    )
    (foreach entnam3 list1
      (if (eq (vla-get-ObjectName entnam3) "AcDbLine")
        (progn
          (setq        entnam41 (vlax-curve-getpointatparam
                           entnam3
                           (/ (vlax-curve-getendparam entnam3) 2.0)
                         )
                entnam42 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
          )
          (if (setq entnam43 (assoc entnam42 list3))
            (progn
              (vla-delete entnam3)
              (vla-delete (cadr entnam43))
            )
            (setq list3 (cons (list entnam42 entnam3) list3))
          )
        )
        (progn
          (setq        list2
                 (append (vlax-safearray->list
                           (vlax-variant-value (vla-explode entnam3))
                         )
                         list2
                 )
          )
          (vla-delete entnam3)
        )
      )
    )
    (foreach entnam3 list2
      (if (eq (vla-get-length entnam3) 0.0)
        (if (not (vlax-erased-p entnam3))
          (vla-delete entnam3)
        )
        (progn
          (setq        entnam41 (vlax-curve-getstartpoint entnam3)
                entnam42 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
                entnam41 (vlax-curve-getendpoint entnam3)
                entnam44 (strcat entnam42
                                 (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                         )
                entnam45 (strcat (rtos (car entnam41) 2 8)
                                 (rtos (cadr entnam41) 2 8)
                                 entnam42
                         )
          )
          (if (or (setq entnam43 (assoc entnam44 list3))
                  (setq entnam43 (assoc entnam45 list3))
              )
            (progn
              (if (not (vlax-erased-p entnam3))
                (vla-delete entnam3)
              )
              (if (not (vlax-erased-p (cadr entnam43)))
                (vla-delete (cadr entnam43))
              )
            )
            (setq list3 (cons (list entnam44 entnam3) list3))
          )
        )
      )
    )
    (vla-delete entnam2)
    (setq i (1+ i))
    (command "zoom" "p")
    (vl-file-delete TempFil)
  )
  (setvar "mirrtext" 0)
  (setvar "osmode" 167)
        (setvar "clayer" clayer)
  (command "undo" "e")
  (princ (strcat "\n提示：共将" (itoa num) "个文字对象成功分解为曲线。\n"))
  (princ)
)
;;;*****分解文字 程序结束*****                                          

wgij007

start4444 发表于 2021-3-4 11:33
;;;*****分解文字 程序开始*****
(defun c:tu (/ PtList)
        (setq clayer (getvar "clayer"))

非常感谢，

gowww

？不太懂这个是做啥用的