Extract Powerpoint text of slides with certain title

[CG159]

I am going crazy over this set of code and I was wondering if anyone could assist me in completing it.... My coding skills are limited and I had someone else help me get this far but we are now stuck.

Try to stay with on this:
Using a Macro in powerpoint, I am trying to extract text from powerpoint slides and output the text in the .ppt file to a .txt file. The text I am trying to extract is based upon a particular slide title.

For example, any slide that is begins with the title," I am number:". I want to take the text from ALL slides from an entire powerpoint that begin with this title and place them into a text file. So slides with the titles "I am number 10", "I am number 12", and am "number 34" would be extracted based upon this code.

I have about 20 powerpoint slides and I need to output a txt file for each powerpoint.

So, the code below should be able to take all 20 files and output a .txt file with the text I need from those slide titles. Some text in the powerpoint may be within a table, it varies.

The problems when I run this code are:

-The output only contains 1 or 2 lines of text and not the whole slide, especially if a table is involved. In which case it only returns the first two columns.

-I cannot get the code to extract every single slide. It stops after 1 slide.

-The code outputs display text instead of hyperlink text. (I think it may be best if I create another macro to change all display text to hyperlink text, but I have been unable to come up with one that works so far)

If anyone could provide any assistance I would be extremely grateful.


[VBA]'~~> Change Slide Title here
Const ppSTitle As String = "Walkthrough"
'~~> Change PPT Source Directory Here
Const sDir As String = "C:\Documents and Settings\r126162\Desktop\test\"

Sub Sample()
Dim ppPrsn As Presentation
Dim ppSlide As Slide
Dim filesize As Integer
Dim shp As Shape
Dim vFile
Dim No As Long

vFile = Dir(sDir & "*.ppt*")

No = 1

Do While vFile <> ""
Set ppPrsn = Presentations.Open(FileName:=sDir & vFile)

For Each ppSlide In ppPrsn.Slides
If InStr(1, ppSlide.Shapes.Title.TextFrame.TextRange.Text, ppSTitle, vbTextCompare) Then
'~~> Get a free file handle
filesize = FreeFile()

'~~> Open your file
Open vFile & ".txt" For Output As #filesize

For Each shp In ppSlide.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
'~~> Export Text
Print #filesize, shp.TextFrame.TextRange.Text & " " & shp.TextFrame.TextRange.Characters.ActionSettings(ppMouseClick).Hyperlink.A ddress
End If
End If
Next

Close #filesize

No = No + 1
Exit For
End If
Next

ppPrsn.Close
vFile = Dir
Loop
Set ppPrsn = Nothing
End Sub[/VBA]

[John Wilson]

It looks like your code is overwriting each previous text file leaving you with just the last slide.

You will need to move the write text file out of the loop.

Table text will only be built up if you loop through the cells there are examples on Shyam Pillai's site

I don't understand the hyperlink bit, text files in Notepad don't have hyperlink capability AFAIK.

[CG159]

Thank you for your help John! I think I'm pretty close so it's been driving me nuts.

It looks like your code is overwriting each previous text file leaving you with just the last slide.

You will need to move the write text file out of the loop.

So am I correct in assuming this means I should place:

[VBA] '~~> Export Text
Print #filesize, shp.TextFrame.TextRange.Text & " " & shp.TextFrame.TextRange.Characters.ActionSettings(ppMouseClick).Hyperlink.A ddress [/VBA]

Right after: [VBA]Loop[/VBA] and right before: [VBA] Set ppPrsn = Nothing[/VBA]?

I don't understand the hyperlink bit, text files in Notepad don't have hyperlink capability AFAIK.

I am attempting to have the full link written out. For example, instead of "Click Here" the output would read, <full URL> when output to the .txt file. I don't need the functionality in notepad, I just need the URL written out.(The .txt file may be imported into another application anyway.)

Is there a way to convert all display text (e.g. "click here") within a powerpoint to the full URL (e.g. <full URL>)?

Would it be more appropriate to have that in a separate thread?

[John Wilson]

More like this (not really tested)

NOTE
The Exit For you added will mean only one slide with the title is found in each presentation. Delete if this is not what you want

[vba]Sub Expand(osld As Slide)
Dim ohl As Hyperlink
Dim strTextToShow As String
For Each ohl In osld.Hyperlinks
If TypeName(ohl.Parent.Parent) = "TextRange" Then
strTextToShow = ohl.Parent.Parent.Text
ohl.Parent.Parent = Replace(ohl.Parent.Parent, strTextToShow, strTextToShow & " <" & ohl.Address & ">")
End If
Next
End Sub



Sub Sample()
Const ppSTitle As String = "Walkthrough"
'~~> Change PPT Source Directory Here
Const sDir As String = "C:\Documents and Settings\r126162\Desktop\test\"
Dim ppPrsn As Presentation
Dim ppSlide As Slide
Dim filesize As Integer
Dim shp As Shape
Dim vFile
Dim No As Long
Dim strReport As String
Dim strName As String
vFile = Dir(sDir & "*.ppt*")

No = 1

Do While vFile <> ""
Set ppPrsn = Presentations.Open(FileName:=sDir & vFile)
strReport = ""
For Each ppSlide In ppPrsn.Slides
If InStr(1, ppSlide.Shapes.Title.TextFrame.TextRange.Text, ppSTitle, vbTextCompare) Then
'expand links (change link text to address)
Call Expand(ppSlide)

For Each shp In ppSlide.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
strReport = strReport & shp.TextFrame.TextRange & vbCrLf
End If
End If
Next

No = No + 1
Exit For
End If
Next
filesize = FreeFile()
'~~> Open your file
strName = Left(vFile, InStr(vFile, ".") - 1)
Open sDir & strName & ".txt" For Output As #filesize
Print #filesize, strReport
Close #filesize
ppPrsn.Saved = True
ppPrsn.Close
vFile = Dir
Loop
Set ppPrsn = Nothing
End Sub
[/vba]

[CG159]

I feel like it's almost there. When I attempt to the run the code nothing happens. I press the "Run Sub" button in the toolbar and nothing happens. Spent half an hour playing with the code and no luck. Any ideas?

More like this (not really tested)

NOTE
The Exit For you added will mean only one slide with the title is found in each presentation. Delete if this is not what you want

[vba]Sub Expand(osld As Slide)
Dim ohl As Hyperlink
Dim strTextToShow As String
For Each ohl In osld.Hyperlinks
If TypeName(ohl.Parent.Parent) = "TextRange" Then
strTextToShow = ohl.Parent.Parent.Text
ohl.Parent.Parent = Replace(ohl.Parent.Parent, strTextToShow, strTextToShow & " <" & ohl.Address & ">")
End If
Next
End Sub



Sub Sample()
Const ppSTitle As String = "Walkthrough"
'~~> Change PPT Source Directory Here
Const sDir As String = "C:\Documents and Settings\r126162\Desktop\test\"
Dim ppPrsn As Presentation
Dim ppSlide As Slide
Dim filesize As Integer
Dim shp As Shape
Dim vFile
Dim No As Long
Dim strReport As String
Dim strName As String
vFile = Dir(sDir & "*.ppt*")

No = 1

Do While vFile <> ""
Set ppPrsn = Presentations.Open(FileName:=sDir & vFile)
strReport = ""
For Each ppSlide In ppPrsn.Slides
If InStr(1, ppSlide.Shapes.Title.TextFrame.TextRange.Text, ppSTitle, vbTextCompare) Then
'expand links (change link text to address)
Call Expand(ppSlide)

For Each shp In ppSlide.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
strReport = strReport & shp.TextFrame.TextRange & vbCrLf
End If
End If
Next

No = No + 1
Exit For
End If
Next
filesize = FreeFile()
'~~> Open your file
strName = Left(vFile, InStr(vFile, ".") - 1)
Open sDir & strName & ".txt" For Output As #filesize
Print #filesize, strReport
Close #filesize
ppPrsn.Saved = True
ppPrsn.Close
vFile = Dir
Loop
Set ppPrsn = Nothing
End Sub
[/vba]

[John Wilson]

Did you look to see if there are new text files in C:\Documents and Settings\r126162\Desktop\test\?? Are you sure there are slides with the correct title?

If there are not maybe post a test file or two because it works here.