TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Slide Title
[tab]Bullet Level 1 Text
[tab][tab]Bullet Level 2 Text
[tab][tab][tab]Bullet Level 3 Text
[tab][tab][tab][tab]Bullet Level 4 Text

The default output file is C:\PowerPoint_Outline.txt.

Sub PPTOutlineToText()

    Dim oSh As Shape
    Dim oSl As Slide
    Dim oTitleShape As Shape
    Dim oTextshape As Shape
    Dim sPresentationText As String
    Dim x As Long

    ' File variables
    Dim sFilename As String
    Dim iFilenum As Integer
    ' Edit this as needed to change the default
    sFilename = "C:\PowerPoint_Outline.txt"

    On Error GoTo ErrorHandler

    sFilename = InputBox("Enter a full path for the outline text file", "Send outline to", sFilename)
    ' No filename?  No file.
    If sFilename = "" Then
        Exit Sub
    End If

    For Each oSl In ActivePresentation.Slides
        For Each oSh In oSl.Shapes
            If oSh.Type = msoPlaceholder Then
                Select Case oSh.PlaceholderFormat.Type
                    ' A title; add other titletypes as needed
                    Case Is = ppPlaceholderCenterTitle, ppPlaceholderTitle
                        Set oTitleShape = oSh
                    ' body or subtitle text; add others as needed
                    Case Is = ppPlaceholderSubtitle, ppPlaceholderBody
                        Set oTextshape = oSh
                    Case Else

                End Select
            End If  ' Shape is a placeholder
        Next    ' Shape

        ' now we have references to our title and text shapes, if any
        ' append the text to the string we're building
        If Not oTitleShape Is Nothing Then
            sPresentationText = sPresentationText _
                & oTitleShape.TextFrame.TextRange.Text _
                & vbCrLf
        Else
            ' force something as a title;
            ' substitute just vbcrlf if you wish
            sPresentationText = sPresentationText _
                & "Slide " & CStr(oSl.SlideIndex) _
                & vbCrLf
        End If

        If Not oTextshape Is Nothing Then
            For x = 1 To oTextshape.TextFrame.TextRange.Paragraphs.Count
                sPresentationText = sPresentationText _
                    & MakeTabs(oTextshape.TextFrame.TextRange.Paragraphs(x).IndentLevel) _
                    & oTextshape.TextFrame.TextRange.Paragraphs(x).Text
                    ' .Paragraph includes trailing linefeed, so don't add it here
            Next    ' paragraph
            ' Add a newline at end of final paragraph though
            sPresentationText = sPresentationText & vbCrLf
        Else
            ' no need to write anything to the file
        End If

        Set oSh = Nothing
        Set oTitleShape = Nothing
        Set oTextshape = Nothing
    Next    ' Slide

    ' now write the file
    iFilenum = FreeFile()
    Open sFilename For Output As iFilenum
    Print #iFilenum, sPresentationText
    Close iFilenum

NormalExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description
    Resume NormalExit

End Sub

Function MakeTabs(lIndentLevel As Long) As String
    Dim x As Long
    Dim sTemp As String
    For x = 1 To lIndentLevel
        sTemp = sTemp & vbTab
    Next
    MakeTabs = sTemp
End Function