获取系统字体列表

highflybird

下面程序可以用来获取Windows已经安装的字体列表：

1. (defun getSysFonts (/ FONTS FONTSFOLDER I ITEM LST SH STR)
   
2.   (setq sh (vlax-create-object "shell.application"))
   
3.   (setq fontsFolder (vlax-invoke sh 'Namespace 20))
   
4.   (vlax-release-object sh)
   
5.   (setq fonts (vlax-invoke fontsFolder 'items))
   
6.   (setq i 0)
   
7.   (setq lst nil)
   
8.   (repeat (vlax-get fonts 'count)
   
9.     (setq item (vlax-invoke fonts 'item i))
   
10.     (setq str (vlax-invoke fontsFolder 'GetDetailsOf item 0)) ;1是类型
    
11.     (setq lst (cons str lst))
    
12.     (setq i (1+ i))
    
13.   )
    
14.   (acad_strlsort lst)
    
15. )
    

(defun getSysFonts (/ FONTS FONTSFOLDER I ITEM LST SH STR)<br />   (setq sh (vlax-create-object "shell.application"))<br />   (setq fontsFolder (vlax-invoke sh 'Namespace 20))<br />   (vlax-release-object sh)<br />   (setq fonts (vlax-invoke fontsFolder 'items))<br />   (setq i 0)<br />   (setq lst nil)<br />   (repeat (vlax-get fonts 'count)<br />     (setq item (vlax-invoke fonts 'item i))<br />     (setq str (vlax-invoke fontsFolder 'GetDetailsOf item 0)) ;1是类型<br />     (setq lst (cons str lst))<br />     (setq i (1+ i))<br />   )<br />   (acad_strlsort lst)<br /> )<br />

也可以用powershell来获取，代码为：

1. (defun getsysFonts ( / myCommand wsh txt lst)
   
2.   (setq myCommand
   
3.     (strcat
   
4.       "powershell.exe -WindowStyle Hidden "
   
5.       "Add-Type -AssemblyName System.Drawing;"
   
6.       "Write-Host '系统中已安装的字体名称 (使用 System.Drawing):'"
   
7.       "(New-Object System.Drawing.Text.InstalledFontCollection).Families | Select-Object -ExpandProperty Name"
   
8.     )
   
9.   )
   
10.   (setq wsh (vlax-create-object "wscript.shell"))
    
11.   (setq res (vlax-invoke wsh 'exec myCommand))
    
12.   (setq txt (vlax-invoke (vlax-get res 'stdout) 'readall))
    
13.   (setq lst (cdr (mysplit txt "[FontFamily: Name=")))
    
14.   (setq lst (mapcar '(lambda (x) (substr x 1 (- (strlen x) 2))) lst))
    
15.   (vlax-release-object wsh)
    
16.   lst
    
17. )
    
18. 
    
19. ;;;分割字符串
    
20. (defun mysplit (str delim / lst i len s)
    
21.   (setq len (strlen delim))
    
22.   (while (setq i (vl-string-search delim str))   
    
23.     (setq s (substr str 1 i))
    
24.     (if (/= s "")
    
25.       (setq lst (cons s lst))
    
26.     )
    
27.     (setq str (substr str (+ 1 len i)))
    
28.   )
    
29.   (if (/= str "")
    
30.     (setq lst (cons str lst))
    
31.   )
    
32.   (reverse lst)
    
33. )
    
34. 
    

(defun getsysFonts ( / myCommand wsh txt lst)<br />   (setq myCommand<br />     (strcat<br />       "powershell.exe -WindowStyle Hidden "<br />       "Add-Type -AssemblyName System.Drawing;"<br />       "Write-Host '系统中已安装的字体名称 (使用 System.Drawing):'"<br />       "(New-Object System.Drawing.Text.InstalledFontCollection).Families | Select-Object -ExpandProperty Name"<br />     )<br />   )<br />   (setq wsh (vlax-create-object "wscript.shell"))<br />   (setq res (vlax-invoke wsh 'exec myCommand))<br />   (setq txt (vlax-invoke (vlax-get res 'stdout) 'readall))<br />   (setq lst (cdr (mysplit txt "[FontFamily: Name=")))<br />   (setq lst (mapcar '(lambda (x) (substr x 1 (- (strlen x) 2))) lst))<br />   (vlax-release-object wsh)<br />   lst<br /> )<br /> <br /> ;;;分割字符串<br /> (defun mysplit (str delim / lst i len s)<br />   (setq len (strlen delim))<br />   (while (setq i (vl-string-search delim str))   <br />     (setq s (substr str 1 i))<br />     (if (/= s "")<br />       (setq lst (cons s lst))<br />     )<br />     (setq str (substr str (+ 1 len i)))<br />   )<br />   (if (/= str "")<br />     (setq lst (cons str lst))<br />   )<br />   (reverse lst)<br /> )<br /> <br />

也可以通过读取系统注册表来获取已安装的字体。
其它方法还有读取windows  字体目录，通过文件名来获取，不过这样获取到的一般是英文名。
大家还有什么好的方法不妨贴出来共享。

MZ_li

为大佬顶一个！

kucha007

也是读注册表。但是Win10有两个路径：
http://bbs.mjtd.com/thread-191808-1-1.html

magicheno

感谢大佬分享