清理多余字体样式和标注样式
本帖最后由 头大无恼 于 2018-6-1 00:17 编辑主程序源码应该是老大的，
拼接改造了一下
主要是拿到别家图纸很多字型，讨厌打开文件时恼人的字体丢失提示
可以根据自己需要修改
可以把所有的文字样式和标注样式清理只保留默认样式。
这样图纸清爽了，哈哈:lol
;清理文字样式
(defun c:wzgy ()
;(SETVAR "CMDECHO" 0)
(command "undo" "be")
(u:reset_dimtextstandard);更改标注样式中的文字样式
(u:reset_textstandard);全部转换至standard
(command "undo" "e")
(princ);静默退出
)
;清理标注样式
(defun c:bzgy()
(u:reset_dimtextstandard)
(command "purge" "dimstyle" "*" "n")
)
;;;②★所有文字归一
;分函数
(defun u:standard_song(stylename /)
(command "style" stylename "宋体""0" "1.0" "0.0" "" "")
(setq filter_style stylename)
)
(defun u:standard_zhanghaishan(stylename /)
(command "style" stylename "张海山锐线体2.0""0" "1.0" "0.0" "" "")
(setq filter_style stylename)
)
(defun u:standard_hei(stylename /)
(command "style" stylename "黑体""0" "1.0" "0.0" "" "")
(setq filter_style stylename)
)
(defun u:standard_yahei(stylename /)
(command "style" stylename "微软雅黑 light""0" "1.0" "0.0" "" "")
(setq filter_style stylename)
)
(defun u:standard_youyuan(stylename /)
(command "style" stylename "幼圆""0" "1.0" "0.0" "" "")
(setq filter_style stylename)
)
(defun u:standard_tianzheng(stylename /)
(command "style" stylename "Romans1.shx,hztxt.shx""0" "1" "0.0" "n" "n" "n");注意这个字型会多一个是否垂直选项所以需要增加一个输入
(setq filter_style stylename)
)
;定义字体归一主函数
(defun u:allinone_textstyle(filter_style / blkobj obj objname atts)
(vlax-for blkobj (vla-get-blocks
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vlax-for obj blkobj
(if (or (= "AcDbMText" (setq objname (vla-get-objectname obj)))
(= "AcDbText" objname)
(= "AcDbAttribute" objname)
(= "AcDbAttributeDefinition" objname)
)
(VL-CATCH-ALL-APPLY 'vla-put-stylename (list obj filter_style))
)
(if (and
(or (= "AcDbMInsertBlock" objname)
(= "AcDbBlockReference" objname)
)
(setq atts (vlax-invoke obj 'GetAttributes))
)
(foreach a atts (VL-CATCH-ALL-APPLY 'vla-put-stylename (list a filter_style)))
)
)
)
);end_defun
(defun u:reset_textstandard (/ filter_style)
(setvar "cmdecho" 0)
(redraw)
(initget "0 1 2 3 4 5 ")
(princ "\n请选择统一后的字型:")
(setq key (getkword "
\n■0:黑体\★1:宋体\★2:微软雅黑 light\■3:张海山锐线体2.0\■4:幼圆\★5:Romans1.shx,hztxt.SHX<默认为0>:"))
(cond
((not key) (u:standard_hei "黑体"));注引号内为字体样式名称
((= key "0") (u:standard_hei "黑体"))
((= key "1") (u:standard_song "宋体"));
((= key "2") (u:standard_yahei "standard"));
((= key "3") (u:standard_zhanghaishan "text1"));
((= key "4") (u:standard_youyuan "幼圆"));
((= key "5") (u:standard_tianzheng "text1"));
);cond
(u:allinone_textstyle filter_style)
(command "purge" "st" "*" "n")
(princ)
)
;;;③★所有标注文字归一
;;;增加遍历和循环获取文件中所有的标注样式,注意先必须运行将当前标注字体改为standard，否则会多出一个样式替代的字体不能换
(defun u:reset_dimtextstandard (/ AcadObject AcadDocument mSpace DimstyCol DimstyCount DimstyName lst txt newtxt dimst txtst)
(VL-LOAD-COM)
(command "-dimstyle" "r" "standard");当前标注样式换为standard【本句用于消除样式替代】
(command "dimtxsty""standard");当前标注字体换为standard
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument Acadobject)
mSpace (vla-get-ModelSpace Acaddocument)
)
(setq DimstyCol (vla-get-dimstyles AcadDocument))
(setq DimstyCount (vla-get-count DimstyCol))
(setq index 0)
(repeat DimstyCount
(setq DimstyName (vla-get-name (vla-item DimstyCol index)));;依次获取标注样式
(princ (strcat "\n" (itoa (1+ index)) "." DimstyName));;列印标注样式
;;;;赋值dimst
(setq dimst DimstyName)
(print dimst)
(setq lst (entget(tblobjname "dimstyle" dimst));赋值1st
txt (assoc 340 lst);赋值txt
)
;;;;替换标注样式字体
(setq newtxt (tblobjname "style" "standard"))
(entmod (subst (cons 340 newtxt) txt lst))
(setq index (1+ index))
)
(princ)
);end_defun
觉得好用可以打赏:lol
l18c19 发表于 2018-5-17 15:07
好程序，若楼主能把涉及到的字体文件上传就更棒啦！
字体都是系统自带的哦，网上搜下大把下，而且字体看自己喜欢，然后修改相应的字型定义字函数就好了。因为每个公司的规范不一样，按自己需求改下吧 我还是习惯用自带的checkstandards命令去对比标准dws文件. 楼主你还在论坛吗？你这个程序，无法修改块里面的文字样式啊。 谢谢分享好用的程序 G版的都是好东西先保存 挺好用的，多谢楼主分享 还好吧，也分什么图，搞不好出来一大推的“？？？？” 好程序，若楼主能把涉及到的字体文件上传就更棒啦！ 代码非常有用 谢谢分享