Extracting PowerPoint Titles Into Excel

[RAECH]

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:


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

[macropod]

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.

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