新增簡報最後一頁，列出本簡報所用字型清單：

Sub ListAllFontsToSlide()
    Dim slideItem As Slide
    Dim shapeItem As Shape
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim fontNames As Collection
    Dim f As Variant
    Dim newSlide As Slide
    Dim textBox As Shape
    
    Set fontNames = New Collection
    
    On Error Resume Next
    
    ' 掃描所有投影片
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            CollectFonts shapeItem, fontNames
        Next shapeItem
    Next slideItem
    
    ' 掃描所有母片與版面配置
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            CollectFonts shapeItem, fontNames
        Next shapeItem
        
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                CollectFonts shapeItem, fontNames
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' 在簡報最後新增一張投影片
    Set newSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutText)
    newSlide.Shapes.Title.TextFrame.TextRange.Text = "簡報字型清單"
    
    ' 建立文字方塊顯示字型清單
    Set textBox = newSlide.Shapes.Placeholders(2)
    textBox.TextFrame.TextRange.Text = "=== 簡報中使用的字型 ===" & vbCrLf
    
    For Each f In fontNames
        textBox.TextFrame.TextRange.Text = textBox.TextFrame.TextRange.Text & f & vbCrLf
    Next f
    
    MsgBox "字型清單已插入到簡報最後一張投影片！", vbInformation
End Sub

Private Sub CollectFonts(shp As Shape, fontNames As Collection)
    Dim subShape As Shape
    Dim rowIdx As Long, colIdx As Long
    
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            CollectFonts subShape, fontNames
        Next subShape
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        AddFont .Cell(rowIdx, colIdx).Shape.TextFrame.TextRange.Font, fontNames
                    End If
                Next colIdx
            Next rowIdx
        End With
    ElseIf shp.HasTextFrame Then
        AddFont shp.TextFrame.TextRange.Font, fontNames
    End If
End Sub

Private Sub AddFont(fnt As Font, fontNames As Collection)
    Dim fontName As String
    
    On Error Resume Next
    fontName = fnt.Name
    If fontName <> "" Then AddUnique fontName, fontNames
    
    fontName = fnt.NameFarEast
    If fontName <> "" Then AddUnique fontName, fontNames
    
    fontName = fnt.NameComplexScript
    If fontName <> "" Then AddUnique fontName, fontNames
    On Error GoTo 0
End Sub

Private Sub AddUnique(name As String, fontNames As Collection)
    Dim f As Variant
    For Each f In fontNames
        If StrComp(f, name, vbTextCompare) = 0 Then Exit Sub
    Next f
    fontNames.Add name
End Sub