Question

我正在尝试将演示文稿中的所有标题提取到具有页面索引的excel电子表格。我的代码总体上运行良好，但不幸的是没有获得所有标题。

我基本上使用了Shapes.HasTitle方法，我的代码有点草率（循环一次以设置将要使用的数组的大小，然后填充数组），但在其他方面则相对简单。

Dim sld As Slide
Dim ppt As PowerPoint.Presentation
Dim wb As Workbook
Dim table As Range
Dim bottomLeft As Range
Dim titlesNPages() As Variant

Set wb = ThisWorkbook
myFileName = Application.GetOpenFilename(filefilter:="PowerPoint Files,*.ppt*;*.pptx*")
If myFileName <> False Then
    Set ppt = PowerPointApp.Presentations.Open(myFileName)
End If

'Setting array to the right size (# of shapes with title)
For Each sld In ppt.slides
    With sld
        If .Shapes.HasTitle Then
            i = i + 1
        End If
    End With
Next sld
ReDim titlesNPages(1 To 2, 1 To i)

i = 0

'Populating array
For Each sld In ppt.slides
    With sld
        If .Shapes.HasTitle Then
        i = i + 1
            titlesNPages(1, i) = .SlideIndex 'Page index
            titlesNPages(2, i) = .Shapes.Title.TextFrame.TextRange.Text 'Title
        End If
    End With
Next sld

With wb.Worksheets("Sheet1")
    Set bottomLeft = .Range("B3").Offset(UBound(titlesNPages, 2) - 1, 1)
    Set table = .Range("B3:" & bottomLeft.Address)
    table.Value = WorksheetFunction.Transpose(titlesNPages)
End With
End Sub

主要问题是Shapes.HasTitle似乎并没有在所有形状的标题中找到，也不是在以除英语以外的其他语言的ppt中产生的标题出现。有什么想法可以使它更好地工作吗？目前，它接近70％的标题（然后，我需要弄清楚如何处理实际上是标题的文本框）

Answer 1

这将在正常演示中显示所有标题。检查每个形状是否具有文本并且是否为占位符。如果两者都为真，则检查标题占位符格式：

Sub GetTitles()
  Dim oSlide As Slide, oShape As Shape
  For Each oSlide In ActivePresentation.Slides
    For Each oShape In oSlide.Shapes
      If oShape.Type = msoPlaceholder And oShape.TextFrame.HasText Then
        If oShape.PlaceholderFormat.Type = ppPlaceholderTitle Or _
        oShape.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
          MsgBox oShape.TextFrame.TextRange.Text
        End If
      End If
    Next oShape
  Next oSlide
End Sub

如果您有一些甲板，用户在其中已将文本框的标题改用于其他用途，反之亦然，则可能必须根据使用的文本大小进行更多检查，并查看形状位置是否在标题的正确区域内。 / p>

如何制作Shapes.HasTitle查找演示文稿中的所有标题（VBA，.ppt）？

1 个答案: