如何不安装字体而预览其效果？

Question

比如有个字体文件d:\123.ttf，不安装这种字体，如何获取这种字体的名称等信息，并且预览其效果？

Answer 1

看看下面这个，是不是有帮助：
http://www.vbgood.com/viewthread.php?tid=74489

Answer 2

我看了那个例子，也查了下GetGlyphOutline的用法，基本没看懂。-_-!!
我说的"不安装这种字体"，只是说我预览完这种字体效果后，这个字体文件不会仍然留在fonts文件夹里就好了。
用AddFontResource可以临时把一个字体文件中的字体添加到系统字体中，而且用完后可以用RemoveFontResource删除掉，但是AddFontResource的返回值是一个long，如何获取它添加的字体并指定到label的font属性呢？

Answer 3

程序启动时先枚举并保存系统所有字体，AddFontResource以后Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)，然后枚举当前字体，比较出哪种字体是新增的，这样貌似可以实现我的要求，不知道还有没有更好的方法？

Answer 4

而且AddFontResource好像无法处理系统中已存在这种字体的情况，继续请教

Answer 5

我记得Office Word有这种效果:
就是别人打的Word文档用了一些特殊字体,拿到你电脑里面用,照样可以显示、预览,但你电脑里面并没有这种字体。不知道这是用的什么技术？顶...

Answer 6

倒没注意word有这种效果，ps是有的，应该是把文字临时给“图形化”了吧，输出时还是要用本机字体来替换的。

Answer 7

引用网络上的：  系统字体管理专家 Windows操作系统虽然提供了字体的管理工具，但其功能相对较弱，例如我们下载了很多新字体，在安装之前想具体的查看每一种字体的效果，那么这个管理工具是不会起到任何作用的，我们能做的就是一个个的双击字体文件以查看效果。有什么办法能够简化这一操作呢？使用FontLister便能轻松搞定。 
   运行FontLister，当前系统中已经安装的字体以列表形式出现在软件的左侧栏，而右侧栏则显示了当前选择字体的具体样式。选择字体后点击“查看→字体信息”，还会弹出一个字体属性窗口。 
提示：FontLister默认显示的字体样例为英文，这就造成了预览中文字体时并不能体现其特性。解决的办法就是在右侧窗口中输入一些中文字符，以方便我们对中文字体的预览。 
  除了查看已经安装的字体，FontLister还可以预览未安装字体样式。点击“查看→更改字体类型→未安装”，就会弹出一个“浏览未安装字体”窗口，在“文件夹”处定位到包含了未安装字体的文件夹，文件夹内的字体文件将会以列表形式出现在“字体列表”框中，点击“确定”按钮，就可以在FontLister查看未安装字体的样式了

Answer 8

fontlist是个软件 下载应用吧 还有好多类似的软件 不知道有没有用 你看看吧 不知道有没有帮助

Answer 9

谢谢xiaoyungua，好几款字体管理软件都有预览未安装字体的功能，我要做的就是用VB来实现它。

Answer 10

这个函数返回的是添加的字体数量，并非句柄，所以嘛....基本不能用。
但是，但可是，你既然可以添加了，也就是说可以知道字体的名字了。用DrawText根据字体名字应该可以直接绘制出文字吧？

Answer 11

回老魏，用AddFontResource添加的如果是新字体，那么通过对比前后系统字体的变化可以获取到字体的名字，但是如果系统中已经存在这种字体，AddFontResource也会正常返回添加的字体数量，这种情况下就无法获取到这种字体的名字了。-_-!!

Answer 12

现在已经实现预览当前系统字体中不存在的字体文件，代码如下：Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1DPrivate Sub Form_Load()
    Text1.Text = App.Path & "\华康海报体.ttf" '测试用的字体（当前系统中没有这种字体）
    List1.Clear
    Dim I As Integer '获取所有系统字体名称并添加到list1中
    For I = 0 To Screen.FontCount - 1
        List1.AddItem Screen.Fonts(I)
    Next
End SubPrivate Sub Command2_Click()
    Debug.Print AddFontResource(Text1.Text) '将测试字体添加到系统字体列表
    Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) '广播系统字体变化这一消息
End SubPrivate Sub Command1_Click() '获取新增加的字体名称
    Me.MousePointer = 11
    Dim I As Integer, j As Integer
    For I = 0 To Screen.FontCount - 1
        For j = 0 To List1.ListCount - 1
            If Screen.Fonts(I) = List1.List(j) Then GoTo NextOne
        Next
        List2.AddItem Screen.Fonts(I) '新增加的字体添加到list2中
NextOne:
    Next
    Me.MousePointer = 0
End SubPrivate Sub List2_Click() '用Label2预览该字体效果
    Label2.Caption = List2.Text
    Label2.FontSize = 20
    Label2.FontName = List2.Text
End SubPrivate Sub Command3_Click() '从系统字体列表中移除这种字体
    Debug.Print RemoveFontResource(Text1.Text)
End Sub

Answer 13

上面的代码无法解决系统中已存在这种字体的问题。
另外如何删除一种系统中现有的字体呢？主要是如何获取某种字体所对应的系统fonts文件夹里的字体文件名呢？