✔ VBA Dashboards Specialist®: VBA Powerpoint - Liste os Títulos e as Notas dos seus Slides - How to get a list of the slide titles and notes text in PowerPoint?

Execute a "difícil" tarefa de colar o código abaixo em um novo módulo e o execute para obter uma lista de todos os Títulos e Notas da sua apresentação.

Option Explicit

Dim fOnlyEmptyNotes As Boolean

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
Dim results As VbMsgBoxResult

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

strNotesText = "Slide Notes from PowerPoint presentation:" & vbCrLf & _
ActivePresentation.FullName & vbCrLf & vbCrLf

' Include only slides with notes in output file?

results = MsgBox("Would you like to ONLY include Slides that actually have Notes in your output file?", _
vbQuestion + vbYesNoCancel, "Output Results")
If results = vbYes Then

fOnlyEmptyNotes = True
strNotesText = strNotesText & _
"IMPORTANT: This file contains only the slides that have Notes!" & vbCrLf & vbCrLf
Else
fOnlyEmptyNotes = False
End If

' did user cancel?
If strFileName = "" Or results = vbCancel 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
If fOnlyEmptyNotes = True Then
' Only output notes for slides with actual note text
If NotesText(oSl) <> vbNullString Then

strNotesText = strNotesText & "-----------------------------------" & vbCrLf
strNotesText = strNotesText & "TITLE: " & SlideTitle(oSl) & vbCrLf

strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
strNotesText = strNotesText & "NOTES: " & NotesText(oSl) & vbCrLf & vbCrLf

End If
Else
' Output all slides
strNotesText = strNotesText & "-----------------------------------" & vbCrLf
strNotesText = strNotesText & "TITLE: " & SlideTitle(oSl) & vbCrLf

strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
strNotesText = strNotesText & "NOTES: " & NotesText(oSl) & vbCrLf & vbCrLf

End If

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

Function SlideTitle (oSl As Slide) As String
Dim oSh As Shape
For Each oSh In oSl.Shapes
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _

Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
If Len(oSh.TextFrame.TextRange.Text) > 0 Then
SlideTitle = oSh.TextFrame.TextRange.Text

Else
SlideTitle = "Slide " & CStr(oSl.SlideIndex)
End If
Exit Function
End If

End If
Next
End Function

Function NotesText (oSl As Slide) As String
' Only looking for Shape.Type = PlaceHolder which contains notes

Dim oSh As Shape

For Each oSh In oSl.NotesPage.Shapes
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then

If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
NotesText = oSh.TextFrame.TextRange.Text
End If

End If
Else
NotesText = vbNullString
End If
End If
Next oSh

End Function