Automatisch geöffnete PPS. Pfad in Zelle Schreiben

Private Function fcReadFiles() As Boolean
Dim lstrFile As String, loZeile As Long
lstrFile = Dir(ThisWorkbook.Path & "\*.pps")
If lstrFile = "" Then Exit Function
Columns("A:A").ClearContents
Do Until lstrFile = ""
loZeile = loZeile + 1
Range("A" & loZeile).Value = ThisWorkbook.Path & "\" & lstrFile
lstrFile = Dir
Loop
fcReadFiles = True
End Function

Private Sub sbZufall()

Dim loAnzahl As Long, loZeile As Long

Dim objPowerpoint As Object

loAnzahl = Cells(Rows.Count, 1).End(xlUp).Row

Randomize

loZeile = Int((loAnzahl * Rnd) + 1)

Set objPowerpoint = CreateObject("Powerpoint.Application")

objPowerpoint.Visible = True

objPowerpoint.Presentations.Open Filename:=Range("A" & loZeile).Value, ReadOnly:=msoFalse

End Sub