获取系统字体列表
下面程序可以用来获取Windows已经安装的字体列表：(defun getSysFonts (/ FONTS FONTSFOLDER I ITEM LST SH STR)
(setq sh (vlax-create-object "shell.application"))
(setq fontsFolder (vlax-invoke sh 'Namespace 20))
(vlax-release-object sh)
(setq fonts (vlax-invoke fontsFolder 'items))
(setq i 0)
(setq lst nil)
(repeat (vlax-get fonts 'count)
(setq item (vlax-invoke fonts 'item i))
(setq str (vlax-invoke fontsFolder 'GetDetailsOf item 0)) ;1是类型
(setq lst (cons str lst))
(setq i (1+ i))
)
(acad_strlsort lst)
)
也可以用powershell来获取，代码为：
(defun getsysFonts ( / myCommand wsh txt lst)
(setq myCommand
(strcat
"powershell.exe -WindowStyle Hidden "
"Add-Type -AssemblyName System.Drawing;"
"Write-Host '系统中已安装的字体名称 (使用 System.Drawing):'"
"(New-Object System.Drawing.Text.InstalledFontCollection).Families | Select-Object -ExpandProperty Name"
)
)
(setq wsh (vlax-create-object "wscript.shell"))
(setq res (vlax-invoke wsh 'exec myCommand))
(setq txt (vlax-invoke (vlax-get res 'stdout) 'readall))
(setq lst (cdr (mysplit txt "[FontFamily: Name=")))
(setq lst (mapcar '(lambda (x) (substr x 1 (- (strlen x) 2))) lst))
(vlax-release-object wsh)
lst
)
;;;分割字符串
(defun mysplit (str delim / lst i len s)
(setq len (strlen delim))
(while (setq i (vl-string-search delim str))
(setq s (substr str 1 i))
(if (/= s "")
(setq lst (cons s lst))
)
(setq str (substr str (+ 1 len i)))
)
(if (/= str "")
(setq lst (cons str lst))
)
(reverse lst)
)
也可以通过读取系统注册表来获取已安装的字体。
其它方法还有读取windows字体目录，通过文件名来获取，不过这样获取到的一般是英文名。
大家还有什么好的方法不妨贴出来共享。
为大佬顶一个！ 本帖最后由 kucha007 于 2025-4-12 16:30 编辑
也是读注册表。但是Win10有两个路径：
http://bbs.mjtd.com/thread-191808-1-1.html 感谢大佬分享
页:
[1]