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

Question

我有一个 PDF 文件，它最初是从 PPT（我无权访问）创建的。我需要从 PDF 的每一页中提取 titles/headings 到一个文档中（格式无关；Excel，记事本，Word，任何东西都可以）。该文件很大，因此无法手动完成，我将不得不为类似的文件再次执行此操作。

我得出结论，将 PDF 转换回 PPT 格式会有所帮助，我正在尝试在 PowerPoint 中编写一个子例程 VBA。请查看下面的代码并建议我可以更改哪些内容来实现此目的？也欢迎其他想法。

注意：转换回 PPT 后，每张幻灯片中的标题不再位于 PowerPoint 中的 'Title' 占位符中。它们只是普通的文本框。我是 VBA 的新手，我已经通过谷歌搜索编译了代码。

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

"幻灯片：1

幻灯片：1

幻灯片：2

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

代码：

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

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

    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox

    strTitles = strTitles _
        & "Slide: " _
        & CStr(oSlide.SlideIndex) & vbCrLf _
        & oSlide.Shapes(1).TextFrame.TextRange.Text _
        & vbCrLf & vbCrLf

        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

Answer 1

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

之前

& vbCrLf & vbCrLf

尝试插入行

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

Answer 2

如果文本框不是占位符，唯一的方法是检查每个形状在幻灯片上的位置。在下面相应地设置 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

Answer 3

（代表 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

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

Extract titles from powerpoint textboxes (not placeholders)?

powerpoint

vba

pdfbox

powerpoint-2013