Necesito un macro excel que abra un powerpoint

Te envio un codigo que utilizo para abrir archivos en general le doy un path y el tipo de archivo que quiero abrir y me trai la direcciones, con este puedes hacer una macro que te convierta las hojas a excel
Option Explicit
Dim j As Long
'Sub Leer_directorio()
' Dim Archivo As String
' Dim i As Integer
'
' Archivo = Dir("C:\JM\01\Archivos Sin respaldo\Musica\")
'
' i = 1
' While Archivo <> ""
'  i = i + 1
'  Archivo = Dir
 ' ActiveWorkbook.Sheets("Leer").Activate
'  ActiveSheet.Cells(i, 2).Value = Archivo
' Wend
'End Sub
'*********************************************************************************************************
'------------------------------------------------------------------------------
'Declaraciones del Api
'------------------------------------------------------------------------------
 'Esta función busca el primer archivo de un Dir
 Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
     ByVal lpFileName As String, _
     lpFindFileData As WIN32_FIND_DATA) As Long
 'Esta el siguiente archivo o directorio
 Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
     ByVal hFindFile As Long, _
     lpFindFileData As WIN32_FIND_DATA) As Long
 Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
     ByVal lpFileName As String) As Long
 'Esta cierra el Handle de búsqueda
 Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
 ' Constantes
 '------------------------------------------------------------------------------
 'Constantes de atributos de archivos
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Otras constantes
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
'UDT
'------------------------------------------------------------------------------
'Estructura para las fechas de los archivos
 Private Type FILETIME
     dwLowDateTime As Long
     dwHighDateTime As Long
 End Type
'Estructura necesaria para la información de archivos
Private Type WIN32_FIND_DATA
     dwFileAttributes As Long
     ftCreationTime As FILETIME
     ftLastAccessTime As FILETIME
     ftLastWriteTime As FILETIME
     nFileSizeHigh As Long
     nFileSizeLow As Long
     dwReserved0 As Long
     dwReserved1 As Long
     cFileName As String * MAX_PATH
     cAlternate As String * 14
End Type
Type T_Tag_Mp3
     Header As String * 3
     SongTitle As String * 30
     Artist  As String * 30
     Album  As String * 30
     Year  As String * 4
     Comment As String * 30
     Genre  As Byte
End Type
Sub Busca_Archivos()
 Dim Path As String
 Dim Pattern As String
 Dim FileSize As Currency
 Dim Count_Archivos As Long
 Dim Count_Dir As Long
 ActiveWorkbook.Sheets("Leer").Activate
 'Path y archivos a buscar
 Path = ActiveSheet.Cells(1, 1).Value
 Pattern = ActiveSheet.Cells(1, 2).Value
 j = 2
 'Llamamos a la función para buscar y que nos retorne algunos datos
  FileSize = Encuentra_Archivos_API(Path, Pattern, Count_Archivos, Count_Dir)
 'Mostramos los resultados
 'Cantidad de archivos encontrados
  MsgBox Count_Archivos & " Archivos encontrados en " & Count_Dir & " Directorios", 64
 'Tamaño Total en Bytes de los archivos encontrados
  MsgBox "Tamaño total de los archivos: " & Path & " = " & _
         Format(FileSize, "#,###,###,##0") & " Bytes", 64
 End Sub
Private Function Encuentra_Archivos_API(Path As String, SearchStr As String, _
                                          FileCount As Long, DirCount As Long)
On Error GoTo EH
 Dim FileName As String
 Dim DirName As String
 Dim dirNames() As String
 Dim nDir As Long
 Dim i, Archivo As Long
 Dim hSearch As Long
 Dim WFD As WIN32_FIND_DATA
 Dim Cont As Long
 Dim ar As String
 Dim Ext As String
 Dim Un_Tag As T_Tag_Mp3
 If Right(Path, 1) <> "\" Then Path = Path & "\"
  ' Buscamos por mas directorios
  nDir = 0
  ReDim dirNames(nDir)
  Cont = True
  hSearch = FindFirstFile(Path & "*", WFD)
  If hSearch <> INVALID_HANDLE_VALUE Then
   Do While Cont
    DirName = Eliminar_Nulos(WFD.cFileName)
    ' Ignora estos directorios
    If (DirName <> ".") And (DirName <> "..") Then
     ' revisa el directrio
     If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
       dirNames(nDir) = DirName
       DirCount = DirCount + 1
       nDir = nDir + 1
       ReDim Preserve dirNames(nDir)
     End If
    End If
    Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
   Loop
   Cont = FindClose(hSearch)
  End If
  hSearch = FindFirstFile(Path & SearchStr, WFD)
  Cont = True
  If hSearch <> INVALID_HANDLE_VALUE Then
   While Cont
    FileName = Eliminar_Nulos(WFD.cFileName)
    If (FileName <> ".") And (FileName <> "..") Then
     Encuentra_Archivos_API = Encuentra_Archivos_API + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
     FileCount = FileCount + 1
     ActiveWorkbook.Sheets("Leer").Activate
     j = j + 1
     If j > 64999 Then
      MsgBox "Existen demasiados archivos por favor seleccione una ruta mas corta", vbOKOnly + vbCritical, _
             "ERROR"
      End
     End If
     ActiveSheet.Cells(j, 1).Value = Path
     ActiveSheet.Cells(j, 2).Value = FileName
     Ext = Right(FileName, 4)
     If Left(Ext, 1) = "." Then
      ActiveSheet.Cells(j, 3).Value = Ext
     End If
     If Ext = ".mp3" Or Ext = ".wma" Then
      ar = Path & FileName
      Archivo = FreeFile
      Open ar For Binary Access Read As Archivo
      Get Archivo, LOF(1) - 127, Un_Tag
      Close Archivo
      ActiveSheet.Cells(j, 4).Value = Eliminar_Nulos(Un_Tag.Album)
      ActiveSheet.Cells(j, 5).Value = Eliminar_Nulos(Un_Tag.Artist)
      ActiveSheet.Cells(j, 6).Value = Eliminar_Nulos(Un_Tag.Comment)
      ActiveSheet.Cells(j, 7).Value = Eliminar_Nulos(Un_Tag.Genre)
      ActiveSheet.Cells(j, 8).Value = Eliminar_Nulos(Un_Tag.Header)
      ActiveSheet.Cells(j, 9).Value = Eliminar_Nulos(Un_Tag.SongTitle)
      ActiveSheet.Cells(j, 10).Value = Eliminar_Nulos(Un_Tag.Year)
     End If
    End If
    Cont = FindNextFile(hSearch, WFD)
   Wend
   Cont = FindClose(hSearch)
  End If
  ' Si estos son Sub Directorios......
  If nDir > 0 Then
   For i = 0 To nDir - 1
    Encuentra_Archivos_API = Encuentra_Archivos_API + Encuentra_Archivos_API(Path & dirNames(i) & "\", _
                                  SearchStr, FileCount, DirCount)
    Next i
  End If
 Exit Function
EH:
 Select Case Err.Number
  Case 1004:
   Resume Next
  Case 63
   Resume Next
  Case Else:
   MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbCritical
   Resume
  End Select
End Function
'Esta función es para formatear los nombres de archivos y directorios. Elimina los CHR(0)
'------------------------------------------------------------------------
Function Eliminar_Nulos(ByVal OriginalStr As String) As String
 If (InStr(OriginalStr, Chr(0)) > 0) Then
  OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
 End If
 Eliminar_Nulos = OriginalStr
End Function

Hola
Gracias por responder, lo aplico y te aviso