快速获取系统字体列表

Windows中的字体都安装在Windows\Fonts目录中，为了保证显示效果经常需要使用特殊字体，在代码中如何确认系统已经安装某种字体呢？其实利用Excel中工具条可以很容易的获取系统字体列表。

Sub GetListOfInstalledFonts()
    Dim ctlFontList As CommandBarControl
    Dim cmbBar As CommandBar
    Dim intCnt As Integer
    Set cmbBar = Application.CommandBars.Add
    Set ctlFontList = cmbBar.Controls.Add(ID:=1728)
    With ActiveSheet
        .Range("A:B").ClearContents
        .[A1:B1] = Array("字体名称", "字体效果")
        For intCnt = 2 To ctlFontList.ListCount
            .Cells(intCnt, 1).Resize(1, 2).Value = ctlFontList.List(intCnt)
            .Cells(intCnt, 2).Font.Name = ctlFontList.List(intCnt)
        Next intCnt
    End With
    cmbBar.Delete
End Sub

首先添加一个临时工具条cmbBar，然后在工具条上添加ID为728的控件，即如下控件，点击右侧展开按钮可以弹出字体扩展列表，这正是我们要获取的列表内容。

循环遍历ctlFontList.List列表，将结果写入工作表的前两列，并设置第二列为相应字体格式，效果如图所示：

纪念一下学习使用小鹤双拼完成的第一篇博客。