Vba 从powerpoint文本框中提取标题（不是占位符）？

我有一个PDF文件，它最初是从PPT创建的（我没有访问权）。我需要从PDF的每一页中提取标题/标题到一个单独的文档中（格式无关；Excel、记事本、Word，任何东西都可以）。该文件是大的，因此，不能手动完成，我将不得不这样做类似的文件再次

我得出结论，将PDF转换回PPT格式会有所帮助，我正在尝试用PowerPoint VBA编写一个子程序。请看一下下面的代码，并建议我可以做些什么更改来实现这一点？也欢迎其他想法

提醒：一旦转换回PPT，每张幻灯片中的标题将不再位于PowerPoint中的“标题”占位符中。它们只是普通的文本框。我是VBA新手，我通过谷歌搜索编译了代码

输出：打印一个带有幻灯片编号列表的记事本文件。对于每张幻灯片，它打印相应幻灯片编号的次数与幻灯片中文本框的打印次数相同。例如：幻灯片1有3个文本框，因此，记事本显示：

“幻灯片：1

幻灯片：1

幻灯片：1

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2“

问题：它没有打印文本框中的文本。实际上，我只需要顶部文本框中的文本（位于幻灯片的第一个或最顶部）

代码：

除了检查变量Shp是否是文本框之外，您实际上并没有对它做任何事情。我没有足够的时间去测试解决方案，但在上线之前

& vbCrLf & vbCrLf

试着插入一行

& ": " & Shp.TextFrame.TextRange.Text _

除了检查变量Shp是否是文本框之外，您实际上并没有对它做任何事情。我没有足够的时间去测试解决方案，但在上线之前

& vbCrLf & vbCrLf

试着插入一行

& ": " & Shp.TextFrame.TextRange.Text _

---

如果文本框不是占位符，唯一的方法是检查每个形状在幻灯片上的位置。在下面相应地设置X和Y

Sub GetTitles()
Dim oSld as Slide
Dim oShp as Shape
Dim myText as String
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Left=X and oShp.Top=Y Then
my Text=oShp.TextFrame.TextRange.Text
Debug.Print myText
End If
Next
Next
End Sub

---

如果文本框不是占位符，唯一的方法是检查每个形状在幻灯片上的位置。在下面相应地设置X和Y

Sub GetTitles()
Dim oSld as Slide
Dim oShp as Shape
Dim myText as String
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Left=X and oShp.Top=Y Then
my Text=oShp.TextFrame.TextRange.Text
Debug.Print myText
End If
Next
Next
End Sub

（代表OP发布）

问题已经解决了。供其他人启动VBA PowerPoint时参考的最终代码：

Sub GatherTitles()

On Error GoTo ErrorHandler

Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape
Dim Count As Integer
Dim Mn As Double

If ActivePresentation.Path = "" Then
    MsgBox "Please save the presentation then try again"
    Exit Sub
End If

#If Mac Then
    PathSep = ":"
#Else
    PathSep = "\"
#End If

On Error Resume Next  ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides
Count = 0

    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
Count = Count + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Count = Count - 1
Dim distmat() As Double
ReDim distmat(0 To Count)
Dim i As Integer
i = 0
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
distmat(i) = Shp.Top
i = i + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Mn = distmat(0)
i = i - 1
For j = 1 To i
If distmat(j) < Mn Then
Mn = distmat(j)
End If
Next j

'Next oSlide

'For Each oSlide In ActiveWindow.Presentation.Slides
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
 If Shp.Top = Mn Then
    strTitles = strTitles _
        & "Slide: " _
        & CStr(oSlide.SlideIndex) & vbCrLf _
        & oSlide.Shapes(1).TextFrame.TextRange.Text _
        & Shp.TextFrame.TextRange.Text & vbCrLf _
        & vbCrLf & vbCrLf
Else
Debug.Print Sld.Name, Shp.Name, "This is not the topmost textbox"
End If

        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select

    Next Shp
Next oSlide
On Error GoTo ErrorHandler

intFileNum = FreeFile

' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
    & PathSep _
    & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
    & "_Titles.TXT"

Open strFilename For Output As intFileNum
Print #intFileNum, strTitles

NormalExit:
Close intFileNum
Exit Sub

ErrorHandler:
MsgBox Err.Description
Resume NormalExit

End Sub

Sub-GatherTitles（）
关于错误转到错误处理程序
像幻灯片一样暗淡的奥斯陆
像字符串一样的模糊字符串
将strFilename设置为字符串
Dim intFileNum作为整数
作为字符串的Dim PathSep
将Shp变暗为形状
将计数设置为整数
双色
如果ActivePresentation.Path=”“，则
MsgBox“请保存演示文稿，然后重试”
出口接头
如果结束
#如果是Mac那么
PathSep=“：”
#否则
PathSep=“\”
#如果结束
错误时，如果幻灯片上没有标题占位符，请继续“下一步”
对于ActiveWindow.Presentation.Slides中的每个oSlide
计数=0
用于奥斯陆的每个Shp。形状
选择案例Shp.Type
Case MsoShapeType.msoTextBox
计数=计数+1
其他情况
Debug.Print Sld.Name，Shp.Name，“这不是一个文本框”
结束选择
下一个小水电
计数=计数-1
Dim distmat（）为双精度
ReDim distmat（0计数）
作为整数的Dim i
i=0
用于奥斯陆的每个Shp。形状
选择案例Shp.Type
Case MsoShapeType.msoTextBox
distmat（i）=上海顶部
i=i+1
其他情况
Debug.Print Sld.Name，Shp.Name，“这不是一个文本框”
结束选择
下一个小水电
Mn=distmat（0）
i=i-1
对于j=1到i
如果distmat（j）

（代表OP发布）

问题已经解决了。供其他人启动VBA PowerPoint时参考的最终代码：

Sub GatherTitles()

On Error GoTo ErrorHandler

Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape
Dim Count As Integer
Dim Mn As Double

If ActivePresentation.Path = "" Then
    MsgBox "Please save the presentation then try again"
    Exit Sub
End If

#If Mac Then
    PathSep = ":"
#Else
    PathSep = "\"
#End If

On Error Resume Next  ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides
Count = 0

    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
Count = Count + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Count = Count - 1
Dim distmat() As Double
ReDim distmat(0 To Count)
Dim i As Integer
i = 0
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
distmat(i) = Shp.Top
i = i + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Mn = distmat(0)
i = i - 1
For j = 1 To i
If distmat(j) < Mn Then
Mn = distmat(j)
End If
Next j

'Next oSlide

'For Each oSlide In ActiveWindow.Presentation.Slides
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
 If Shp.Top = Mn Then
    strTitles = strTitles _
        & "Slide: " _
        & CStr(oSlide.SlideIndex) & vbCrLf _
        & oSlide.Shapes(1).TextFrame.TextRange.Text _
        & Shp.TextFrame.TextRange.Text & vbCrLf _
        & vbCrLf & vbCrLf
Else
Debug.Print Sld.Name, Shp.Name, "This is not the topmost textbox"
End If

        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select

    Next Shp
Next oSlide
On Error GoTo ErrorHandler

intFileNum = FreeFile

' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
    & PathSep _
    & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
    & "_Titles.TXT"

Open strFilename For Output As intFileNum
Print #intFileNum, strTitles

NormalExit:
Close intFileNum
Exit Sub

ErrorHandler:
MsgBox Err.Description
Resume NormalExit

End Sub

Sub-GatherTitles（）
关于错误转到错误处理程序
像幻灯片一样暗淡的奥斯陆
像字符串一样的模糊字符串
将strFilename设置为字符串
Dim intFileNum作为整数
作为字符串的Dim PathSep
将Shp变暗为形状
将计数设置为整数
双色
如果ActivePresentation.Path=”“，则
MsgBox“请保存演示文稿，然后重试”
出口接头
如果结束
#如果是Mac那么
PathSep=“：”
#否则
PathSep=“\”
#如果结束
错误时，如果幻灯片上没有标题占位符，请继续“下一步”
对于ActiveWindow.Presentation.Slides中的每个oSlide
计数=0
用于奥斯陆的每个Shp。形状
选择案例Shp.Type
Case MsoShapeType.msoTextBox
计数=计数+1
其他情况
Debug.Print Sld.Name，Shp.Name，“这不是一个文本框”
结束选择
下一个小水电
计数=计数-1
Dim distmat（）为双精度
ReDim distmat（0计数）
作为整数的Dim i
i=0
用于奥斯陆的每个Shp。形状
选择案例Shp.Type
Case MsoShapeType.msoTextBox
distmat（i）=上海顶部
i=i+1
其他情况
Debug.Print Sld.Name，Shp.Name，“这不是一个文本框”
结束选择
下一个小水电
Mn=distmat（0）
i=i-1
对于j=1到i
如果distmat（j）