從PowerPoint文本框中提取標題（不是佔位符）？

Question

我有一個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 

Answer 1

你真的不是做任何與變量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