求帮助改一段程序.分解文字
本帖最后由 wgij007 于 2021-3-4 09:02 编辑求帮助改一段程序，出处明经，忘了那个贴了，如有侵犯请提出，必改。能不能改为，打散后，不变图层与颜色。
;;;*****分解文字 程序开始*****
(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"
TempFilLTPoint
"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)
)
;;;*****分解文字 程序结束*****
;;;*****分解文字 程序开始*****
(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"
TempFilLTPoint
"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)
)
;;;*****分解文字 程序结束***** start4444 发表于 2021-3-4 11:33
;;;*****分解文字 程序开始*****
(defun c:tu (/ PtList)
(setq clayer (getvar "clayer"))
非常感谢， ？不太懂这个是做啥用的
页:
[1]