如何制作形状。在演示文稿中查找所有标题（VBA、.ppt）？

我正在尝试将演示文稿中的所有标题提取到excel电子表格及其页面索引中。我的代码总体上运行得比较好，但不幸的是，并不是每个标题都能找到

我基本上使用了

Shapes.hasttle

方法，我的代码有点马虎（循环一次以设置将使用的数组的大小，然后填充数组），但在其他方面相对简单

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

将sld设置为幻灯片
将ppt变暗为PowerPoint。演示文稿
将wb设置为工作簿
调暗表作为范围
暗淡的左下角范围
Dim titlesNPages（）作为变量
设置wb=ThisWorkbook
myFileName=Application.GetOpenFilename（文件过滤器：=“PowerPoint文件，*.ppt*；*.pptx*”）
如果myFileName为False，则
设置ppt=PowerPointApp.Presentations.Open（myFileName）
如果结束
'将数组设置为正确大小（#带标题的形状）
对于ppt幻灯片中的每个sld
使用sld
如果.Shapes.hasttle那么
i=i+1
如果结束
以
下一个sld
重读标题页（1到2，1到i）
i=0
'填充数组
对于ppt幻灯片中的每个sld
使用sld
如果.Shapes.hasttle那么
i=i+1
标题页（1，i）=.SlideIndex'页面索引
titlesnpage（2，i）=.Shapes.Title.TextFrame.TextRange.Text”标题
如果结束
以
下一个sld
带工作分解表（“表1”）
设置左下角=.Range（“B3”）.Offset（UBound（titlesNPages，2）-1,1）
Set table=.Range（“B3:”&bottomLeft.Address）
table.Value=WorksheetFunction.Transpose（titlesnpage）
以
端接头

主要的问题是Shapes.HasTitle似乎没有注意到所有的形状都是标题，也没有注意到ppt中使用英语以外的语言制作的标题。

---

有什么办法可以让它更好地工作吗？它目前接近70%的标题（然后我需要弄清楚如何处理实际上是标题的文本框）

这将在正常的演示中获得所有标题。将检查每个形状是否包含文本以及是否为占位符。如果两者均为真，则检查标题占位符格式：

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

---

如果您有套牌，用户可以为文本框重新设置标题，反之亦然，您可能需要根据使用的文本大小进行更多检查，并查看形状位置是否位于标题的正确区域。

谢谢您的回答！这看起来很有希望。你能给我一个快速的指针，告诉我如何检查文本大小和形状位置吗？位置：If oShape.Left>36和oShape.Left<108和oShape.Top>36和oShape.Top<108然后文本大小：If oShape.TextFrame.TextRange.Font.size>36，谢谢你的帮助！