字体分类更换

nyistjz · 发表于 2020-12-23 14:36:40

本帖最后由 nyistjz 于 2020-12-24 12:50 编辑

修改好的源码在11楼。

nyistjz · 发表于 2020-12-24 12:47:14

本帖最后由 nyistjz 于 2020-12-24 12:48 编辑

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) "秒。"))
)

bssurvey · 发表于 2020-12-23 15:10:02

試看看是不是這樣，大家一起學習
(defun c:tty (/ font font_obj fontlist fontname n toshx tottf)
  (defun toshx(shx 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 tottf(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
   ((= font "*黑体*")(tottf "黑体"))
   ((= font "*仿宋*")(tottf "仿宋"))
   ((= font "*宋体*")(tottf "宋体"))
   (t(toshx "tssdeng.shx" "hztxt.shx"))
)
(setq n (+ n 1))
  )
  (repeat 1 (vl-cmdf "regen"))
)

bssurvey · 发表于 2020-12-24 10:31:07

本帖最后由 bssurvey 于 2020-12-24 10:39 编辑

nyistjz 发表于 2020-12-24 09:58
你还没有看懂这个程序的运行顺序，是从第12行开始的。

真的很抱歉
看看是不是這樣
(defun c:tty (/ font font_obj fontlist fontname n toshx tottf)
  (defun toshx(shxx shxb / a3)
(setq a3 (entget (tblobjname "style" font)));取出字体的数据串行
(setq a3 (subst (cons 3 shxx)(assoc 3 a3) a3));将字体字型改成新字型
(entmod a3);更新字体                ; 增加这一行就可以了
(setq a3 (subst (cons 4 shxb)(assoc 4 a3) a3));将字体字型改成新字型
(entmod a3);更新字体
  )
  (defun tottf(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 "*黑体*")(tottf "黑体"))
   ((wcmatch font "*仿宋*")(tottf "仿宋"))
   ((wcmatch font "*宋体*")(tottf "宋体"))
   (t(toshx "tssdeng.shx" "hztxt.shx"))
)
(setq n (+ n 1))
  )
  (repeat 1 (vl-cmdf "regen"))
)

nyistjz · 发表于 2020-12-23 15:17:33

bssurvey 发表于 2020-12-23 15:10
試看看是不是這樣，大家一起學習
(defun c:tty (/ font font_obj fontlist fontname n toshx tottf) ...

你测试一下，好像是不行的。

bssurvey · 发表于 2020-12-23 15:27:09

本帖最后由 bssurvey 于 2020-12-23 15:33 编辑

nyistjz 发表于 2020-12-23 15:17
你测试一下，好像是不行的。

(tblobjname "style" "font") font 要圖檔有的字型名稱，例如"Standard"

nyistjz · 发表于 2020-12-23 15:32:56

bssurvey 发表于 2020-12-23 15:27
(tblobjname "style" "font") font 要圖檔有的字型名稱，例如"Standard" 好像沒用到(defun tottf(ttf / ...

(setq font (nth n fontlist))
有这个定义！

bssurvey · 发表于 2020-12-23 17:26:56

nyistjz 发表于 2020-12-23 15:32
(setq font (nth n fontlist))
有这个定义！

(setq a3 (subst (cons 3 shxx )(assoc 3 a3) a3));将字体字型改成新字型應該是shxx 並沒有設定變數，是哪一個新字型，所以才會出錯
(setq a3 (subst (cons 4 shxb )(assoc 4 a3) a3));将字体字型改成新字型這個shxb 也是一樣

nyistjz · 发表于 2020-12-24 09:58:35

bssurvey 发表于 2020-12-23 17:26
(setq a3 (subst (cons 3 shxx )(assoc 3 a3) a3));将字体字型改成新字型應該是shxx 並沒有設定變數， ...

你还没有看懂这个程序的运行顺序，是从第12行开始的。

nyistjz · 发表于 2020-12-24 10:49:34

bssurvey 发表于 2020-12-24 10:31
真的很抱歉
看看是不是這樣
(defun c:tty (/ font font_obj fontlist fontname n toshx tottf) ...

谢谢您，还是不对，您自己在电脑上试一下，看能不能运行。
我怀疑(entmod a3)解析出来的a3格式不对，所以entmod运行不了。

bssurvey · 发表于 2020-12-24 10:58:19

本帖最后由 bssurvey 于 2020-12-24 11:01 编辑

nyistjz 发表于 2020-12-24 10:49
谢谢您，还是不对，您自己在电脑上试一下，看能不能运行。
我怀疑(entmod a3)解析出来的a3格式不对，所 ...

我在2008測試是沒問題的

账号		自动登录	找回密码
密码			注册

[源码] 字体分类更换