获取 PowerPoint 有权访问的字体列表并与用户输入进行比较

Question

我想创建一个宏来设置整个 PowerPoint 中所有文本框的字体。

我有设置它们的代码，但为了进行错误处理，我需要确保用户输入的字体有效，因此我需要 PowerPoint 已安装的完整字体集。

Private Sub ChangeTextFont_Click()

Dim oSl As Slide
Dim oSh As Shape
Dim strFontName As String
Dim ValidFont As Font

strFontName = InputBox("Enter the name of the font to use for the text on the screens or press Cancel to keep the existing font.", "Enter Font Name")

If Trim(strFontName) = "" Then Exit Sub

'For Each ValidFont In <collection of all fonts powerpoint has>    <-------- this is my issue
    If strFontName = ValidFont Then
        With ActivePresentation
            For Each oSl In .Slides
                For Each oSh In oSl.Shapes
                    With oSh
                        If .HasTextFrame Then
                            If .TextFrame.HasText Then
                                If oSl.Name <> "Config" Then
                                    .TextFrame.TextRange.Font.Name = strFontName
                                End If
                            End If
                        End If
                    End With
                Next
            Next
        End With
    End If
'Next
End Sub

理想情况下，我需要的解决方案只使用 PowerPoint（不启动 Word，因为它有不同的字体选择）并且不会太长，因为这不应该是一个难题。

Answer 1

您可以尝试查看安装目录中的 Microsoft Office\root\Office1633\PUBFTSCM\FONTSCHM.INI 文件，然后对其进行解析...

不确定其中的哪种数据会有帮助，但这是一个开始。

Answer 2

所以最后这是从 word 中提取列表最简单的方法。我认为列表不同，但这是由于我正在比较的文档中缓存了字体。无论如何，为了一个好的解决方案，请查看这个问题的答案：

获取 PowerPoint 有权访问的字体列表并与用户输入进行比较

Get list of fonts to which PowerPoint has access to and compare to user input

powerpoint

vba

office365