'PPT text scraping function...
 
 
Function PutCursorInAndPressF5()
 
    ' PPT text scraping function...
    ' press ALT-F11 while in PowerPoint (development environment will appear)
    ' right-click the VBA project (top-left) and select Insert Module
    ' double-click inserted module to open in
    ' paste this text in the module
    ' click within the PutCursorInAndPressF5() function and press F5
    ' function will scrape all text from the active PowerPoint presentation and put that text into the clipboard
    ' WARNING: the capacity of the string variable MIGHT be too short for a very long presentation,
    ' but it worked like a charm for a 229 slides presentation with 240+ KB of text (more than 1000 lines).
 
    ' made on 2014-12-11 by Gjuro Kladaric to help Denis Marijon with his problem of collecting text from PPT for blind people
    ' free to use for whatever purpuse one wants :-)  no warranties whatsoever :-))
 
    Dim myPresentation As presentation
    Dim slideCount As Integer
    Dim currentSlide As Slide
    Dim currentShape As Shape
    Dim currentTextFrame As TextFrame
    Dim fullText As String
    Dim text As String
   
    Set myPresentation = Application.Presentations(1)
    slideCount = myPresentation.Slides.Count
    fullText = ""
    text = ""
   
    For slideNum = 1 To slideCount
        Set currentSlide = myPresentation.Slides(slideNum)
        fullText = fullText & vbCrLf & vbCrLf & "Slide: " & slideNum
        For shapenum = 1 To currentSlide.Shapes.Count
            Set currentShape = currentSlide.Shapes(shapenum)
            If currentShape.HasTextFrame Then
                Set currentTextFrame = currentShape.TextFrame
                If currentTextFrame.HasText Then
                    text = doTrim(currentTextFrame.TextRange.text)
                    If text <> "" Then
                        fullText = fullText & vbCrLf & text
                    End If
                End If
            End If
        Next shapenum
    Next slideNum
   
    Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MSForms_DataObject.SetText fullText
    MSForms_DataObject.PutInClipboard
    Set MSForms_DataObject = Nothing
 
    MsgBox "Tekst spremljen u clipboard."
   
End Function
 
Function doTrim(text As String) As String
 
    Do
        If Left(text, 1) = vbCr Then
            text = Mid(text, 2)
        ElseIf Left(text, 1) = vbLf Then
            text = Mid(text, 2)
        ElseIf Left(text, 1) = " " Then
            text = Mid(text, 2)
        Else
            Exit Do
        End If
    Loop While True
   
    Do
        If Right(text, 1) = vbCr Then
            text = Mid(text, 1, Len(text) - 1)
        ElseIf Right(text, 1) = vbLf Then
            text = Mid(text, 1, Len(text) - 1)
        ElseIf Right(text, 1) = " " Then
            text = Mid(text, 1, Len(text) - 1)
        Else
            Exit Do
        End If
    Loop While True
 
    doTrim = text
   
End Function