✔ Programação GLOBAL®: 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