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?












Como obter uma lista dos títulos de slides e notas de texto no 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


Tags: VBA, Powerpoint, list, slide, titles, notes


Nenhum comentário:

Postar um comentário

diHITT - Notícias