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

Sub GetFontList()
    Dim i As Long
    Dim font As Font
    Dim fontList As String
    
    ' 获取当前PPT中所有文本框的字体
    For Each Slide In ActivePresentation.Slides
        For Each Shape In Slide.Shapes
            If Shape.HasTextFrame Then
                For Each Paragraph In Shape.TextFrame.TextRange.Paragraphs
                    For Each Run In Paragraph.Runs
                        If Run.Font.Name <> "" Then
                            ' 将字体添加到字体列表
                            If InStr(fontList, Run.Font.Name) = 0 Then
                                fontList = fontList & Run.Font.Name & vbCrLf
                            End If
                        End If
                    Next Run
                Next Paragraph
            End If
        Next Shape
    Next Slide
    
    ' 显示字体列表
    If fontList <> "" Then
        MsgBox "字体列表：" & vbCrLf & fontList
    Else
        MsgBox "未找到字体"
    End If
End Sub