Extracting PowerPoint Titles Into Excel

Hi

I don't know if this belongs here or in the PP subfora?

I am looking for a code (in Excel) that can open up PowerPoint and loop through each slide to get the Titles. The goal is to make a list in Excel of EACH slide (=also the slides without a proper Title shape).

Today we do this manually with a PP Module where we generate an Notepad.txt document from which we then Ctrl+C/V into our Excel.
Why? The purpose of this exercise is to generate a Table of Contents of our Management Reporting presentation, where some of our Senior Management wants a hardcopy of the presentation with a TOC. And so far, this method has been the best used. In Excel we add the slide numbers from a "ROW()" formula. (Why it is important to also get slides without title)

Our code in PowerPoint now is:

Code:

---

Sub getTitles2()

 Dim PPSlide As Slide
 Dim sReport As String
 Dim iFilenum As Integer
 Dim FilePath As String
 For Each PPSlide In ActivePresentation.Slides


    If PPSlide.Shapes.HasTitle Then
        If PPSlide.Shapes.Title.TextFrame.HasText Then
            sReport = sReport & PPSlide.Shapes.Title.TextFrame.TextRange & vbCrLf
        Else:
            sReport = sReport & "No title text" & vbCrLf
        End If
    Else
        sReport = sReport & "No title" & vbCrLf
    End If
 Next PPSlide


 iFilenum = FreeFile
 FilePath = Environ("TEMP") & "\data.txt"
 Open FilePath For Output As iFilenum
 Print #iFilenum, sReport
 Close iFilenum
 Call Shell("Notepad.exe " & FilePath, vbNormalFocus)
 
 End Sub

---

In summary: Extract the titles and insert them into Sheet(x) starting from A1 and down.

Is this possible?

Best regards
Rasmus

Here's some code I wrote recently for a church that uses PowerPoint for songs they sing. Naturally, as each song spans multiple slides, the same song title appears multiple times. Amongst other things, for my purposes the code automates Word rather than Excel and cleans up & formats both the output and titles themselves, as well as producing a sorted text file. For your purposes, you could use much the same code to automate Excel and do the sorting there without bothering with the text file. You may or may not want some of the other tweaks I mentioned.

Code:

---

Sub GetTitles()
Dim WdApp As New Word.Application, wdDoc As Word.Document, DataArray() As String
Dim Sld As Slide, StrTmp As String, StrNms As String, StrFlNm As String
StrFlNm = ActivePresentation.Path & "\Titles.txt"
Set wdDoc = WdApp.Documents.Add
For Each Sld In ActivePresentation.Slides
  With Sld
    If .Shapes.Count > 0 Then
      With .Shapes(1)
        If .Type = msoPlaceholder Then
          StrTmp = Trim(Replace(Split(Split(.TextFrame.TextRange.Text, vbCr)(0), Chr(11))(0), "  ", " "))
          If InStr(StrNms, StrTmp) = 0 Then
            wdDoc.Range.Text = StrTmp
            wdDoc.Range.Case = wdTitleWord
            StrTmp = wdDoc.Range.Text
            StrNms = StrNms & StrTmp
          End If
          If .TextFrame.TextRange.Text <> StrTmp Then .TextFrame.TextRange.Text = StrTmp
        End If
      End With
    End If
  End With
Next
StrNms = Left(StrNms, Len(StrNms) - 1)
DataArray() = Split(StrNms, vbCr)
WdApp.WordBasic.SortArray DataArray()
wdDoc.Range.Text = Join(DataArray(), vbCr)
wdDoc.SaveAs2 FileName:=StrFlNm, FileFormat:=wdFormatText, AddToRecentFiles:=False
wdDoc.Close False: WdApp.Quit
Set wdDoc = Nothing: Set WdApp = Nothing
End Sub

---