设置字体样式

st788796 · 发表于 2019-1-25 11:54:26

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;设置 ttf 字体
(defun xd::setfont (name tname width / ts st flst n)
(if (and (not (tblsearch "style" name))
(setq flst (apply 'append (xdrx_get_fonts t)))
(setq n (car (vl-member-if
'(lambda (x) (equal (strcase x) (strcase tname)))
flst
)
)
)
)
(progn
(setq ts (vla-get-textstyles
(vla-get-activedocument (vlax-get-acad-object))
)
st (vla-add ts name)
)
(vla-setfont st n :vlax-false :vlax-false 1 0)
(vla-put-width st width)
t
)
)
)
;;设置 shx 字体，大字体+英文字体
(defun xd::setefont (name bigfont fontfile width / ts st)
(if (not (wcmatch bigfont "*.shx"))
(setq bigfont (strcat bigfont ".shx"))
)
(if (not (wcmatch fontfile "*.shx"))
(setq fontfile (strcat fontfile ".shx"))
)
(if (and (not (tblsearch "style" name))
(findfile bigfont)
(findfile fontfile)
)
(progn
(setq ts (vla-get-textstyles
(vla-get-activedocument (vlax-get-acad-object))
)
st (vla-add ts name)
)
(vla-put-bigfontfile st bigfont)
(vla-put-fontfile st fontfile)
(vla-put-width st width)
t
)
)
)

;;设置 ttf 字体 
 
(defun xd::setfont (name tname width / ts st flst n) 
  (if (and (not (tblsearch "style" name)) 
           (setq flst (apply 'append (xdrx_get_fonts t))) 
           (setq n (car        (vl-member-if 
                          '(lambda (x) (equal (strcase x) (strcase tname))) 
                          flst 
                        ) 
                   ) 
           ) 
      ) 
    (progn 
      (setq ts (vla-get-textstyles 
                 (vla-get-activedocument (vlax-get-acad-object)) 
               ) 
            st (vla-add ts name) 
      ) 
      (vla-setfont st n :vlax-false :vlax-false 1 0) 
      (vla-put-width st width) 
      t 
    ) 
  ) 
) 
;;设置  shx 字体，大字体+英文字体 
(defun xd::setefont (name bigfont fontfile width / ts st) 
  (if (not (wcmatch bigfont "*.shx")) 
    (setq bigfont (strcat bigfont ".shx")) 
  ) 
  (if (not (wcmatch fontfile "*.shx")) 
    (setq fontfile (strcat fontfile ".shx")) 
  ) 
  (if (and (not (tblsearch "style" name)) 
           (findfile bigfont) 
           (findfile fontfile) 
      ) 
    (progn 
      (setq ts (vla-get-textstyles 
                 (vla-get-activedocument (vlax-get-acad-object)) 
               ) 
            st (vla-add ts name) 
      ) 
      (vla-put-bigfontfile st bigfont) 
      (vla-put-fontfile st fontfile) 
      (vla-put-width st width) 
      t 
    ) 
  ) 
)

Lisphk · 发表于 2019-1-25 13:15:40

谢谢大师分享代码，xdrx_get_fonts新函数？有详细用法吗？谢谢！

st788796 · 发表于 2019-1-25 14:04:38

本帖最后由 st788796 于 2019-1-25 14:08 编辑

xdrx_get_fonts 可以获取系统中安装的字体名称

1 获取系统中安装的字体名称（本地名称，中文系统中如宋体、黑体、仿宋、微软雅黑 ...)

(xdrx_get_fonts)

复制代码

2 获取系统中安装的字体的详细信息，子表形式 (字体名称字体英文名称字体文件名)

(xdrx_get_fonts t)

复制代码

3 有字体文件获取该字体文件中的字体名称
a)对 TTF 字体，返回(字体本地名称字体英文名)

(xdrx_get_fonts "bell.ttf")

复制代码

b)对 TTC 字体，返回表，可能为 ((字体名1 字体英文名1) (字体名2 字体英文名2) ...)

(xdrx_get_fonts "simsun.ttc")

复制代码

4 用本地名称获取英文名称及字体文件名

(xdrx_get_fonts "宋体")

复制代码

5 由英文名称获取本地名称，返回表 (字体英文名称本地名称1 本地名称2 ...)

(xdrx_get_fonts "simsun")

复制代码

在中文Windows系统中，字体英文名是区分大小写的，程序中要严格按注册的大小写名称设置才能成功
测试

_$ (xdrx_get_fonts "simsun")
("SimSun" "@宋体" "宋体" "simsun.ttc")
_$ (xdrx_get_fonts "simsun.ttc")
(("@宋体" "SimSun") ("@新宋体" "NSimSun") ("宋体" "SimSun") ("新宋体" "NSimSun"))
_$ (xdrx_get_fonts "宋体")
("SimSun" "simsun.ttc")
_$ (xdrx_get_fonts "bell.ttf")
("Bell MT" "Bell MT")

Lisphk · 发表于 2019-1-25 14:10:11

st788796 发表于 2019-1-25 14:04
xdrx_get_fonts 可以获取系统中安装的字体名称

1 获取系统中安装的字体名称（本地名称，中文系统中如宋 ...

感谢

st788796 · 发表于 2019-1-25 14:14:21

XDRX API 1.24 中包含此函数

kqqt6236 · 发表于 2019-1-25 18:07:43

能正常显示乱码吗

evayleung · 发表于 2019-1-25 19:05:48

谢谢分享、。。。。。、。。。。。。

konglong604 · 发表于 2019-1-26 12:36:03

谢谢大师分享代码

xudi1234 · 发表于 2019-1-27 18:25:09

自动替换缺的图纸?

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

[每日一码] 设置字体样式

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。