如何將 powerpoint 幻燈片注釋導出到單個文本文件？

Question

通過一些研究，我在以下站點上發現了這個 VBA 代碼： http : //www.pptfaq.com/FAQ00481_Export_the_notes_text_of_a_presentation.htm

Sub ExportNotesText()

Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long

' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")

' did user cancel?
If strFileName = "" Then
    Exit Sub
End If

' is the path valid?  crude but effective test:  try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then     ' we have a problem
    MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
        & "Please try again."
    Exit Sub
End If
Close #intFileNum  ' temporarily

' Get the notes text
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
    For Each oSh In oSl.NotesPage.Shapes
    If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        If oSh.HasTextFrame Then
            If oSh.TextFrame.HasText Then
                strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
                & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
            End If
        End If
    End If
    Next oSh
Next oSl

' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum

' show what we've done
lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)
End Sub

它本質上是按照幻燈片的時間順序將 Powerpoint 文件中的所有幻燈片注釋導出到一個文本文件中。

無論如何要更改代碼以將幻燈片注釋輸出到多個文本文件中？ 我的意思是，如果powerpoint 文檔中有4 張幻燈片，我們將導出每張幻燈片的注釋，如下所示：

• 幻燈片1notes.txt
• 幻燈片筆記.txt
• 幻燈片3notes.txt
• 幻燈片筆記.txt

非常感謝。

Answer 1

我沒有太多的時間做更多的事情，但是：

Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
'       xxx is the slide number

Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer

' Get the notes text
For Each oSl In ActivePresentation.Slides
    For Each oSh In oSl.NotesPage.Shapes
        If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
            If oSh.HasTextFrame Then
                If oSh.TextFrame.HasText Then
                    ' now write the text to file
                    strFileName = ActivePresentation.Path _
                        & "\" & ActivePresentation.Name & "_Notes_" _
                        & "Slide_" & CStr(oSl.SlideIndex) _
                        & ".TXT"
                    intFileNum = FreeFile()
                    Open strFileName For Output As intFileNum
                    Print #intFileNum, oSh.TextFrame.TextRange.Text
                    Close #intFileNum
                End If
            End If
        End If
    Next oSh
Next oSl

End Sub

Answer 2

由於 Mac PPT/VBA 存在漏洞，這里有一個適用於 Mac 的新版本。 由於我在 PC 上執行此操作並且無法復制/粘貼到/從 Mac 復制/粘貼，因此我沒有在 Mac 上運行代碼，但應該沒問題：

Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
'       xxx is the slide number

Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer

' Since Mac PPT will toss non-fatal errors, just keep moving along:
On Error Resume Next

' Get the notes text
For Each oSl In ActivePresentation.Slides
    For Each oSh In oSl.NotesPage.Shapes

        ' Here's where the error will occur, if any:
        If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        ' so deal with it if so:
        If Err.Number = 0 Then 
            If oSh.HasTextFrame Then
                If oSh.TextFrame.HasText Then
                    ' now write the text to file
                    strFileName = ActivePresentation.Path _
                        & "\" & ActivePresentation.Name & "_Notes_" _
                        & "Slide_" & CStr(oSl.SlideIndex) _
                        & ".TXT"
                    intFileNum = FreeFile()
                    Open strFileName For Output As intFileNum
                    Print #intFileNum, oSh.TextFrame.TextRange.Text
                    Close #intFileNum
                End If  ' HasText
            End If   ' HasTextFrame
        End If  ' Err.Number = 0
        End If  ' PlaceholderType test
    Next oSh
Next oSl

End Sub

Answer 3

如果有人需要一個 txt 文件中的輸出：

Sub TryThis()
' Write each slide's notes to a text file
' in same directory as presentation itself
' Each file is named NNNN_Notes_Slide_xxx
' where NNNN is the name of the presentation
'       xxx is the slide number

Dim oSl As Slide
Dim oSh As Shape
Dim strFileName As String
Dim strNotesText As String
Dim intFileNum As Integer
Dim strLine As String
Dim strData As String

' Since Mac PPT will toss non-fatal errors, just keep moving along:
On Error Resume Next

' Get the notes text
For Each oSl In ActivePresentation.Slides
    For Each oSh In oSl.NotesPage.Shapes

        ' Here's where the error will occur, if any:
        If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        ' so deal with it if so:
        If Err.Number = 0 Then
            If oSh.HasTextFrame Then
                If oSh.TextFrame.HasText Then
                    strData = strData + "Folie " & oSl.SlideIndex & vbCrLf & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
                    Close #intFileNum
                End If  ' HasText
            End If   ' HasTextFrame
        End If  ' Err.Number = 0
        End If  ' PlaceholderType test
    Next oSh
Next oSl

' now write the text to file
strFileName = ActivePresentation.Path _
& "\" & ActivePresentation.Name & "_Notes" _
& ".txt"
intFileNum = FreeFile()
Open strFileName For Output As intFileNum
Print #intFileNum, strData
Close #intFileNum

End Sub