Originally Posted by
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]