VBA提取Excel的系统字体名字

此技巧的关键是知道改系统控件的ID号。

代码如下：

Sub 提取当前电脑已安装字体名称()                                        '定义子程序名称
    Dim fontlist As Object                                     '定义字体列表为对象
    s = Timer                                                  '开始计时：秒
    Dim i As Long, arr                                              '定义变量I为整数                                                                                                         '选择A列
    Columns("A:A").ClearContents                               '清空A列原有数据
    Application.ScreenUpdating = False                         '关闭屏幕刷新
    Set fontlist = Application.CommandBars("Formatting").FindControl(ID:=1728)    '获取字体设置控件对象
    If fontlist.ListCount > 0 Then
        ReDim arr(1 To fontlist.ListCount, 1 To 1)
        For i = 1 To fontlist.ListCount                            '通过循环i遍历所有字体名称
            arr(i, 1) = fontlist.List(i)                    '输出字体名称。
        Next i                                                     '循环下一个
        [a2].Resize(UBound(arr)) = arr                             ''输出结果
        Range("a1:a" & UBound(arr) + 1).EntireRow.AutoFit           'a列自动调整所有行高
        Range("a2:a" & UBound(arr) + 1).Borders.LineStyle = xlContinuous           'a列 a2 开始自动添加边框
        Cells(1, 1) = "VBA提取当前电脑已安装字体名称" & vbNewLine & "共计：" & i & "个字体"    '第1列第1行显示"VBA提取本电脑已安装字体名称"
        Call 单元格设置                                                 '调用“字体设置”子程序
        Application.ScreenUpdating = True                          '打开屏幕刷新
        MsgBox "总用时：" & Timer - s & "秒" & vbNewLine & "当前电脑已安装字体：" & fontlist.ListCount & "个", vbOKOnly, "已完成当前电脑字体名称提取"    '显示提取字体的总用时"秒"及提取字体的数量
    End If
End Sub

实例见：实例文件下载