消除字体样式 $0$

尘缘一生

没事想解决这个问题，写了段代码，调试有问题，又不想保存，还不想丢弃，由于加了块内实体，速度慢，这都是需要研究一下子。。。。
那么存这里吧。希望有人把这个课题完成。

• 
  
  • (if (null vlax-dump-object) (vl-load-com));;将 Visual LISP 扩展功能加载到 AutoLISP----0000级加载
  • ;;常量定义
  • (setq *Acad* (vlax-get-acad-object)
  •   *AcDocument* (vla-get-activedocument *Acad*)  ; 获取当前图档指针
  •   *Model-Space* (vla-get-modelspace *AcDocument*)
  •   *Paper-Space* (vla-get-PaperSpace *AcDocument*)
  •   *BLKS* (vla-get-Blocks *AcDocument*)
  •   *LAYS* (vla-get-Layers *AcDocument*)
  •   *ACLYS*  (vla-get-activeLayer *AcDocument*)
  •   *LTS*  (vla-get-Linetypes *AcDocument*)
  •   pi2     (* pi 0.5)
  •   pi4     (* pi 0.25)
  •   3pi4   (* 0.75 pi)
  •   2pi     (+ pi pi)
  •   3pi2   (+ 3pi4 3pi4)  ;; (* 1.5 pi)
  •   5pi4   (+ pi pi4)  ;;(* 1.25 pi)
  •   7pi4   (+ 3pi2 pi4) ;;(* 1.75 pi)
  • )
  • ;;返回 obj的 vla对象名-------(一级)------------------
  • (defun en2obj (object)
  •   (cond
  •     ((= (type object) 'vla-object)
  •       object
  •     )
  •     ((= (type object) 'ename)
  •       (vl-catch-all-apply '(lambda () (setq object (vlax-ename->vla-object object))))  ;;避免天正实体出错退出
  •     )
  •   )
  •   object
  • )
  • ;;返回 vla对象->ename对象名-------(一级)----------------
  • (defun obj2en (object)
  •   (if (equal (type object) 'vla-object)
  •     (setq object (vlax-vla-object->ename object))
  •     object
  •   )
  •   object
  • )
  • ;;块内所有实体表-----（一级）----
  • (defun kualst (bname / blk kua lst name1 ty)
  •   (setq kua (cdr (assoc 2 (entget bname))) lst '())
  •   (setq blk (tblobjname "Block" kua))
  •   (while (setq name1 (entnext blk))
  •     (setq ty (cdr (assoc 0 (entget name1))))
  •     (if (= ty "INSERT")
  •       (setq lst (cons name1 lst) lst (append (kualst name1) lst))
  •       (setq lst (cons name1 lst))
  •     )
  •     (setq blk name1)
  •   )
  •   lst
  • )
  • ;;字符串以旧换新------------(一级)--------
  • (defun t-string-subst (new old str / n)
  •   (setq n (- (strlen new)))
  •   (while (setq n (vl-string-search old str (min (+ n (strlen new)) (strlen str))))
  •     (setq str (vl-string-subst new old str n))
  •   )
  •   str
  • )
  • ;提取除参照外所有图元----(一级)---------
  • ;返回((0 obj1) (图层2 obj2)......)
  • (defun allenam (/ b1 obj enamlis tc)
  •   (setq enamlis '())
  •   (vlax-for obj *Model-Space*
  •     (if (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))
  •       (setq enamlis (cons (list tc obj) enamlis))
  •     )
  •   )
  •   (vlax-for b1 *BLKS*
  •     (vlax-for obj b1
  •       (if (and (null (vl-catch-all-error-p (setq tc (vl-catch-all-apply 'vla-get-layer (list obj)))))
  •             (= :vlax-false (vla-get-isxref b1)) ;;非参照
  •           )
  •         (setq enamlis (cons (list tc obj) enamlis))
  •       )
  •     )
  •   )
  •   enamlis
  • )
  • ;;全图文字样式表----（一级）---
  • (defun slstylist (/ stylis stydxf styname)
  •   (setq stydxf (tblnext "STYLE" T) stylis '())
  •   (while stydxf
  •     (setq styname (dxf1 stydxf 2))
  •     (if (/= styname "")
  •       (setq stylis (append stylis (list styname)))
  •     )
  •     (setq stydxf (tblnext "STYLE"))
  •   )  
  •   stylis
  • )
  • ;;选择集改文字样式(支持标注、属性块、嵌套块内文字)---（一级）----
  • ;;ss 选择集  styi 比较中文字样式  sty 要改变文字样式
  • (defun ch-ss-sty (ss styi sty / ent ent1 i lst name name1 tp sty0)
  •   (repeat (setq i (sslength ss))
  •     (setq ent (entget (setq name (ssname ss (setq i (1- i)))))
  •       tp (dxf1  ent 0) sty0 (dxf1 ent 7)
  •     )
  •     (cond
  •       ((member tp '("TEXT" "MTEXT"))
  •         (if (= sty0 styi)
  •           (entmod (emod ent 7 sty))
  •         )
  •       )
  •       ((= tp "DIMENSION")
  •         (setq sty0 (vlax-get (en2obj name) 'TextStyle))
  •         (if (= sty0 styi)
  •           (progn
  •             (command "DIMOVERRIDE" "DIMTXSTY" sty "dimfit" 3 "" name "")
  •             (entmod ent)
  •           )
  •         )
  •       )
  •       ((member tp '("INSERT"))
  •         (setq ent1 ent)
  •         (while (= (dxf1 (setq ent1 (entget (entnext (dxf1 ent1 -1)))) 0) "ATTRIB")
  •           (setq sty0 (dxf1 ent1 7))
  •           (if (= sty0 styi)
  •             (progn
  •               (setq ent1 (emod ent1 7 sty))
  •               (entmod ent1)
  •               (entmod ent)
  •             )
  •           )
  •         )
  •         (setq lst (kualst name))
  •         (foreach name1 lst
  •           (setq ent1 (entget name1))
  •           (if (member (dxf1 ent1 0) '("TEXT" "MTEXT"))
  •             (progn
  •               (setq sty0 (dxf1 ent1 7))
  •               (if (= sty0 styi)
  •                 (entmod (emod ent1 7 sty))
  •               )
  •             )
  •           )
  •         )
  •         (entmod ent)
  •       )
  •     )
  •   )
  •   (princ)
  • )
  • ;元素列表→选择集----------(一级)-----------
  • (defun sl:pickset-fromlist (eList / ss)
  •   (setq ss (ssadd))
  •   (while eList
  •     (if (equal (type (car eList)) 'ENAME)
  •       (setq ss (ssadd (car eList) ss))
  •     )
  •     (setq eList (cdr elist))
  •   )
  •   ss
  • )
  • ;;去除字体样式 $0$----参照
  • (defun del$0$ (/ stylis enamlis elis styi styii)
  •   (setq stylis (slstylist) elis '())
  •   (setq enamlis (allenam))
  •   (repeat (setq i (length enamlis))
  •     (setq enami (obj2en (cadr (nth (setq i (1- i)) enamlis))))
  •     (setq elis (cons enami elis))
  •   )
  •   (setq ss (sl:pickset-fromlist elis))
  •   ;;(setq ss (ssget "x" '((0 . "TEXT,MTEXT,DIMENSION,INSERT,ATTRIB"))))
  •   (repeat (setq i (length stylis))
  •     (setq styi (nth (setq i (1- i)) stylis))
  •     (setq styii (t-string-subst "" "$0$" styi))  
  •     (setq styii (t-string-subst "" "-参照" styii))
  •     (if (/= styii styi)
  •       (ch-ss-sty ss styi styii)
  •     )
  •   )
  •   (command "purge" "st" "*" "n")
  • )
  • (del$0$)
    
• 
  
  

czb203

        赞一个!

怕怕吓一跳

我也遇到了这种图，好像这个代码运行不了，期待有高手能完成这个

flowerson

缺少 DXF1 函数 楼主和补上不？

尘缘一生

flowerson 发表于 2022-11-11 20:41
缺少 DXF1 函数 楼主和补上不？

;取得图元参数值内容-----(一级)-------
;;(setq h (dxf1 ent 40))
; ent 为实体名或实体entget，
(defun dxf1 (ent i / tmp)
        (if (= (type ent) 'ENAME)
                (setq ent (entget ent '("*")))
        )
        (setq tmp (cdr (assoc i ent)))
        (if (null tmp)
                (cond
                        ((= i 66) 0)
                        ((= i 48) (getvar "celtscale"))
            ((= i 62) 256)
            ((= i 370) (setq tmp -1))
            ((= i 6) "ByLayer")
                )
                tmp  
        )
)

yuanziyou

一个小建议：插入代码可使用顶栏的插入代码按钮，方便复制和编辑。

尘缘一生

• ;;已有文字样式表----(一级)------
• ;返回("Standard" "图框-结构$0$黑" "MtXpl_" "檩托|Standard")
• (defun getexiststynams (/ FontStys exstylis stynam)
•   (setq FontStys (tblnext "STYLE" T))
•   (while FontStys
•     (setq stynam (dxf1 FontStys 2))
•     (if (/= stynam "")
•       (setq exstylis (append exstylis (list stynam)))
•     )
•     (setq FontStys (tblnext "STYLE"))
•   )  
•   exstylis
• )
• ;;重命名字体样式 去除$0$;参照----(一级)------(rensty$0$)
• (defun rensty$0$ (/ i n stylis sty stnew fstName fsdxf)
•   (setq stylis (getexiststynams))
•   (repeat (setq i (length stylis))
•     (setq sty (nth (setq i (1- i)) stylis) stnew sty)
•     (while (vl-string-search "\#" stnew 0) (setq stnew (vl-string-subst "" "\#" stnew)));去#的样式名称
•     (while (setq n (vl-string-search "$" stnew 0)) (setq stnew (substr stnew (+ 2 n))));处理有$的样式名称
•     (setq stnew (t-string-subst "" (slmsg "-参照" "-把酚" "-reference") stnew))
•     (setq stnew (t-string-subst "" "|" stnew))
•     (if (and (/= stnew sty) (= (tblobjname "style" stnew) nil))
•       (progn
•         (setq fstName (tblobjname "style" sty))
•         (setq fsdxf (entget fstName))
•         (entmod (emod fsdxf 2 stnew))
•         (entupd fstName)
•       )
•     )
•   )
• )
  

cheng_0804

感觉你在处理文字样式名称时特别绕。逻辑是不是可以优化下：1、历遍所有的文字样式名称放入一个列表内，2、循环列表内所有的每一个文字样式名称为oldName，如果带有$0$字符的文字样式名称，就以“$0$”为分割符进行分割字符串，分割后的字符应该变成字符数组了，那么该数组内最后一组元素就是newName了，3、将循环的每一个oldName替换成newName，如果newName已存在，就将oldName赋值的文字样式删除了，这样就能清除掉文字样式中所有的带$0$之前的文字前缀。

wojiaohuyong

    赞一个!赞一个!