Option ExplicitSub CreatePPTDirectory()
'Declare PowerPoint variables
Dim ppApp As Object
Dim ppPres As Object
Dim ppSlide As Object
'Declare Excel variables
Dim vFileNames As Variant
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim NextRow As Long
Dim i As Long
Dim bNew As Boolean
'Prompt user to select one or more PowerPoint files
vFileNames = Application.GetOpenFilename( _
FileFilter:="PowerPoint Files (*.pptx;*.pptm), *.pptx;*.pptm", _
Title:="Select one or more PowerPoint Files . . .", _
ButtonText:="Select", _
MultiSelect:=True)
'If user cancels, exit the sub
If Not IsArray(vFileNames) Then Exit Sub
'Turn off screen updating
Application.ScreenUpdating = False
'Create a new workbook in which to list the information
Set wbDest = Application.Workbooks.Add(Template:=xlWBATWorksheet)
'Start PowerPoint, if not already open
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
If ppApp Is Nothing Then
Set ppApp = CreateObject("PowerPoint.Application")
bNew = True
End If
On Error GoTo 0
'Open each PowerPoint file and list its corresponding information in a newly created worksheet
For i = 1 To UBound(vFileNames)
'Error exist - Added the following line
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Open(vFileNames(i))
Set wsDest = wbDest.Worksheets.Add(Before:=wbDest.Worksheets(i))
With wsDest
'Changed File Name to Hyperlink
.Range("A1:C1").Value = Array("Hyperlink", "Slide Title", "Slide Number")
'Deleted the Hyperlink line
NextRow = 2
For Each ppSlide In ppPres.Slides
.Cells(NextRow, "B").Value = GetSlideTitle(ppSlide)
.Cells(NextRow, "C").Value = ppSlide.SlideNumber
'Replace the Hyperlink line with this
.Cells(NextRow, "A").Hyperlinks.Add Anchor:=.Cells(NextRow, "A"), Address:=vFileNames(i), TextToDisplay:="Open File"
NextRow = NextRow + 1
Next ppSlide
'Error exist - Deleted name line
End With
ppPres.Close
Next i
'Auto fit
Columns("A:C").Select
Columns("A:C").EntireColumn.AutoFit
'Delete the extra sheet, and make the first sheet the active sheet
With wbDest
Application.DisplayAlerts = False
.Worksheets(.Worksheets.Count).Delete
Application.DisplayAlerts = True
.Worksheets(1).Activate
End With
'Quit PowerPoint, if it was started
If bNew Then
ppApp.Quit
End If
'Turn on screen updating
Application.ScreenUpdating = True
'Clear the variables from memory
Set ppApp = Nothing
Set ppPres = Nothing
Set ppSlide = Nothing
Set wbDest = Nothing
Set wsDest = Nothing
End Sub
Private Function GetSlideTitle(ByVal ppSlide As Object) As String
Dim ppPlaceHolder As Object
For Each ppPlaceHolder In ppSlide.Shapes.Placeholders
Select Case ppPlaceHolder.PlaceholderFormat.Type
Case 1, 3, 5 'ppPlaceholderTitle, ppPlaceholderCenterTitle, and ppPlaceholderVerticalTitle
GetSlideTitle = ppPlaceHolder.TextFrame2.TextRange.Text
Exit Function
End Select
Next ppPlaceHolder
'If there is no title slide it will show as "No Title"
GetSlideTitle = "No Title"
End Function
