字体分类更换

nyistjz

bssurvey 发表于 2020-12-24 10:58
我在2008測試是沒問題的

朋友，你是对的，确实是字体的问题，是在定义变量时少写了一个字母，导致出错。修改后放在这里，供有需要的朋友自取。
两种方法，效果一致。


(defun c:11E (/ date1 date2 font font_obj fontlist fontname n to-shx to-ttf)
        (setq date1 (getvar "millisecs"))
        (defun to-shx(shxx shxb / a3)
                (setq a3 (entget (tblobjname "style" font)));取出字体的数据串行
                (setq a3 (subst (cons 3 shxx )(assoc 3 a3) a3));将字体字型改成新字型
                (setq a3 (subst (cons 4 shxb )(assoc 4 a3) a3));将字体字型改成新字型
                (entmod a3);更新字体
        )
        (defun to-ttf(ttf / obj)
                (setq obj (vla-add font_obj font))
                (vla-setFont obj ttf :vlax-false :vlax-false 134 2)
        )
        (setq font_obj (vla-get-TextStyles(vla-get-ActiveDocument(vlax-get-acad-object))))
        (vlax-for sobj font_obj
                (setq fontname (vla-get-name sobj))
                (setq fontlist (vl-remove "" (cons fontname fontlist)))
        )
        (setq n 0)
        (repeat (length fontlist)
                (setq font (nth n fontlist))
                (cond
                        ((wcmatch font "*仿宋*")(to-ttf "仿宋"))
                        ((wcmatch font "*宋体*")(to-ttf "宋体"))
                        ((wcmatch font "*黑体*")(to-ttf "黑体"))
                        (t(to-shx "tssdeng.shx" "hztxt.shx"))
                )
                (setq n (+ n 1))
        )
        (repeat 1 (vl-cmdf "regen"))
        (setq date2 (getvar "millisecs"))
        (princ (strcat "，耗时" (rtos(/(- date2 date1)1000.000)2 3) "秒。"))
)



(defun C:22E(/ a1 a2 date1 date2 to-shx to-ttf)
        (setq date1 (getvar "millisecs"))
        (defun to-shx(shxx shxb / a3)
                (setq a3 (entget (tblobjname "style" a2)));取出字体的数据串行
                (setq a3 (subst (cons 3 shxx )(assoc 3 a3) a3));将字体字型改成新字型
                (setq a3 (subst (cons 4 shxb )(assoc 4 a3) a3));将字体字型改成新字型
                (entmod a3);更新字体
        )
        (defun to-ttf(ttf / font_obj obj)
                (setq font_obj (vla-get-TextStyles(vla-get-ActiveDocument(vlax-get-acad-object))))
                (setq obj (vla-add font_obj a2))
                (vla-setFont obj ttf :vlax-false :vlax-false 134 2)
        )
        (setq a1 (tblnext "style" t));将指针移到第一个字体
        (while a1
                (setq a2 (cdr (assoc 2 a1)));取出字体名称
                (cond
                        ((wcmatch a2 "*仿宋*")(to-ttf "仿宋"))
                        ((wcmatch a2 "*宋体*")(to-ttf "宋体"))
                        ((wcmatch a2 "*黑体*")(to-ttf "黑体"))
                        (t(to-shx "tssdeng.shx" "hztxt.shx"))
                )
                (setq a1 (tblnext "style"));找出下一个字体
        )
        (repeat 1 (vl-cmdf "regen"))
        (setq date2 (getvar "millisecs"))
        (princ (strcat "，耗时" (rtos(/(- date2 date1)1000.000)2 3) "秒。"))
)

xj6019

谢谢慷慨分享  

muwind

nyistjz 发表于 2020-12-24 12:47
朋友，你是对的，确实是字体的问题，是在定义变量时少写了一个字母，导致出错。修改后放在这里，供有需要 ...

(setq a2 (cdr (assoc 2 a1)));取出字体名称
获取的是文字样式名，比如STANDARD，按您的代码 下面的cond前面三个条件应该都是恒false的,除非您的文字样式名直接按字体的名字命名的。

nyistjz

muwind 发表于 2020-12-26 23:29
(setq a2 (cdr (assoc 2 a1)));取出字体名称
获取的是文字样式名，比如STANDARD，按您的代码 下面的con ...

你说对，特定字体粗体，打印或者看起来醒目，其它的都是细体，缩放迅速！
如果想统一改成一种字体，简单修改即可。

muwind

nyistjz 发表于 2020-12-28 09:38
你说对，特定字体粗体，打印或者看起来醒目，其它的都是细体，缩放迅速！
如果想统一改成一种字体，简单 ...

这种修改应该还有种问题，就是会把形文件给替换了，形文件的文字样式名字在获取的2组码都显示为空“”，但还能entget获取组码并能修改，为空的文字样式我估计是线型什么的自动创建的。比如你可能获取到下面的DXF组码:
((-1 . <图元名: 7ffffb09300>) (0 . "STYLE") (330 . <图元名: 7ffffb06830>) (5 . "508")
(100 . "AcDbSymbolTableRecord") (100 . "AcDbTextStyleTableRecord") (2 . "") (70
. 1) (40 . 0.0) (41 . 1.0) (50 . 0.0) (71 . 0) (42 . 5.0) (3 . "zads") (4 .
"htj_d"))

nyistjz

muwind 发表于 2020-12-28 23:41
这种修改应该还有种问题，就是会把形文件给替换了，形文件的文字样式名字在获取的2组码都显示为空“”， ...

因为我平时不画图，只是用来看图而已，所以对字体的显示其实要求不高，只要能正常显示就行了。
如果你想在不破坏原有字形的基础上替换的话，还有个替换空字体，源码如下，你看是否有用。
这个源码的出处，我现在也记不得了，如果对原作者有冒犯，还请见谅。

• (defun nulltoFonts(shxx shxb ttf / err font_obj)
•   (vl-load-com)
•   (setq font_obj (vla-get-TextStyles(vla-get-ActiveDocument(vlax-get-acad-object))))
•   (vlax-for x font_obj ;单独分离函数时需重新定义font_obj
•     (vla-getfont x 'a 'b 'c 'd 'e)
•     (if (= a "")
•       (progn
•         (if (and
•               (not (findfile (vla-get-fontfile x)))
•               (not (findfile (strcat (vla-get-fontfile x) ".shx")))
•             )
•           (vla-put-fontfile x shxx)
•         )
•         (if (and
•               (/= (vla-get-bigfontfile x) "")
•               (not (findfile (vla-get-bigfontfile x)))
•               (not (findfile (strcat (vla-get-bigfontfile x) ".shx")))
•             )
•           (vla-put-bigfontfile x shxb)
•         )
•       )
•       (progn
•         (setq err (vl-catch-all-apply 'vla-setfont (list x a b c d e)))
•         (if (vl-catch-all-error-p err)
•           (vla-setfont x ttf b c d e)
•         )
•       )
•     )
•   )
•   (princ(strcat "\n>>>空字体分别替换为" shxx "、" shxb "、" ttf))
•   (repeat 1 (vl-cmdf "regen"))
•   (princ)
• )
• (nulltoFonts "tssdeng" "hztxt" "仿宋")