消除字体样式 $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 (dxf1ent 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$)
**** Hidden Message ***** 赞一个! 我也遇到了这种图，好像这个代码运行不了，期待有高手能完成这个
页:
[1]