PowerPoint VBA question

[Marty Girvan]

I have an excel file with 5 hyperlinks. The hyperlinks are locations on a server of PowerPoint slides all in different locations. I have been working with another individual, gary, from the excel group (here is a link to myoriginal post): https://groups.google.com/forum/#!topic/microsoft.public.excel.programming/gT7ngWeCCzA

Anyhow, I am working on some code in Excel to create some automation. My goal is for a macro to run and create a new PowerPoint presentation and to then open the 5 PowerPoint slides in the excel sheet and place them into thepresentation in the order they are listed in the excel file.

So I have been working to do this through the Excel file and the conversation came up that this could be done in PowerPoint too with the use of VBA. Either way I would like to see it work in Excel and PowerPoint for learningand experience.

Where I am stuck. The code partially works but it is not inserting the slides. It generates a new PowerPoint presentation but none of the slides show up, only a a new blank slide. The code is posted below. Let me know if anyone has some thoughts. Thanks for viewing.

Code for the whole module (three different macros):

Option Explicit

Const sPath$ = "C:\Users\Marty\Documents\"

Sub CreatePowerPoint()
Dim vList, n&
Dim vFile

vList = ActiveSheet.Range("A1:A5")
On Error GoTo Cleanup
'Automate a new instance of PowerPoint
With CreateObject("PowerPoint.Application")
.Visible = True
'Add a new presentation
With .Presentations.Add
'Insert the slides into the presentation
For n = LBound(vList) To UBound(vList)
.slides.InsertFromFile vFile(n, 1), .slides.Count + 1
Next 'n
End With '.Presentations.Add
End With 'CreateObject
Cleanup:
End Sub

Sub InsertSlidesFromFile()
' Inserts slides from a list of PPTs stored in a txt file
Dim vList, n&
Dim vFile

vList = Split(ReadTextFile(sPath & "auto.txt"), vbCrLf)
On Error GoTo Cleanup
'Add a new presentation
With Application.Presentations.Add
'Insert the slides into the presentation
For n = LBound(vList) To UBound(vList)
.slides.InsertFromFile sPath & vFile(n), .slides.Count + 1
Next 'n
End With 'Application.Presentations.Add
Cleanup:
End Sub

Sub InsertSlidesFromFolder()
' Inserts slides from a list of PPTs stored in a txt file
Dim vFile, n&

vFile = Dir(sPath)
On Error GoTo Cleanup
'Add a new presentation
With Application.Presentations.Add
'Insert the slides into the presentation
Do While Len(vFile)
.slides.InsertFromFile sPath & vFile, .slides.Count + 1
vFile = Dir()
Loop
End With 'Application.Presentations.Add
Cleanup:
End Sub

Function ReadTextFile$(Filename$)
' Reads large amounts of data from a text file in one single step.
Dim iNum%
On Error GoTo ErrHandler
iNum = FreeFile(): Open Filename For Input As #iNum
ReadTextFile = Space$(LOF(iNum))
ReadTextFile = Input(LOF(iNum), iNum)

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Function 'ReadTextFile()

 

[Marty Girvan]

Here is the code if anyone wants to play with it. Some small issues but still works.

Sub CheckThenAuto()

' Find Dead Hyperlinks
Dim c As Range
Dim vList, n&, oPres

'CHANGE - Here you will need to change the name of the worksheet you want and the range of cells to check
For Each c In Worksheets("Sheet1").Range("A1:A5") 'Change range to suit

If c.Value = "" Then End

If FileExists(c.Hyperlinks(1).Address) = "False" Then

With c.Interior 'Color cell with dead link Yellow
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With

End If
Next

MsgBox "Check Complete"

vList = ActiveSheet.Range("A1:A5")
On Error GoTo Cleanup
'Automate a new instance of PowerPoint
' Set appPPT = CreateObject("PowerPoint.Application")
With CreateObject("PowerPoint.Application") 'appPPT
'Add a new presentation
Set oPres = .Presentations.Add
With oPres.slides
'Insert the slides into the presentation
For n = LBound(vList) To UBound(vList)
.InsertFromFile vList(n, 1), .Count
Next 'n
End With 'oPres.slides
.Visible = True
End With 'CreateObject
Cleanup:
Set oPres = Nothing

End Sub

Function FileExists(PathName As String) As Boolean

Dim Temp As Integer

On Error Resume Next 'Ignore errors

Temp = GetAttr(PathName)

Select Case Err.Number 'Check if error exists and set response
Case Is = 0
FileExists = True
Case Else
FileExists = False
End Select

End Function