1

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

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

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

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

“幻灯片：1

幻灯片：1

幻灯片：1

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：2

幻灯片：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
4

3 回答 3

0

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

& vbCrLf & vbCrLf

尝试插入线

& ": " & Shp.TextFrame.TextRange.Text _
于 2015-07-19T13:41:07.080 回答
0

如果文本框不是占位符，唯一的方法是检查幻灯片上每个形状的位置。在下面相应地设置 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
于 2015-07-19T13:46:59.427 回答
0

（代表 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
于 2015-07-20T12:30:43.623 回答