error en código de exportación de consulta a excel

Option Compare Database

Option Explicit

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _

    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub ExpProgEmit_Click()

    Dim rst As DAO.Recordset

    Dim XL As Object

    Dim miSql As String

    Dim dbs As DAO.Database

    Dim rutaPlantilla As String

    Dim nuevoExcel As String

    Dim vNombrePrograma As String

    Dim Ruta: Ruta = CurrentProject.Path: Ruta = Left(Ruta, InStrRev(Ruta, "\")) & "tmp_SGRADIO_CAPTAv1.0 EXPORTA\"

    vNombrePrograma = Nz(Me.NombrePrograma.Value, "")

    ' Crear una nueva instancia de Excel

    Set XL = CreateObject("Excel.Application")

    Set dbs = CurrentDb

    miSql = "SELECT [ProgramaEmitido].* FROM [ProgramaEmitido]"

    Set rst = dbs.OpenRecordset(miSql, dbOpenSnapshot)

    ' Asignar la ruta hasta la carpeta para el nuevo Excel

    nuevoExcel = Ruta

    ' Coger la ruta de la plantilla

    rutaPlantilla = Ruta & "\PLANTILLAS\PlantillaPM.xls"

    ' Abrir la plantilla de Excel

    Call ShellExecute(Me.hwnd, "Open", rutaPlantilla, "", "", 1)

    With XL

    .DisplayAlerts = False

    .Workbooks.Open rutaPlantilla

    .Sheets("Hoja1").Select

    .Range("A2").Select

    .ActiveCell.CopyFromRecordset rst

    .ActiveSheet.Protect Password:="190668", AllowFiltering:=True 'Proteger

    .ActiveWorkbook.SaveAs nuevoExcel & "ProdMusicalv1.0 " & DLookup("FProg", "ProgramaEmitidoFecha") & ".xls"

    .ActiveWorkbook.Close SaveChanges:=False

    .DisplayAlerts = True

    .Quit

    End With

    Dim miArchivo As Object

    Set miArchivo = GetObject(nuevoExcel & "ProdMusicalv1.0 " & DLookup("FProg", "ProgramaEmitidoFecha") & ".xls")

    miArchivo.Close SaveChanges:=False

    Set miArchivo = Nothing

    Dim plantilla As Object

    Set plantilla = GetObject(rutaPlantilla)

    plantilla.Close SaveChanges:=False

    Set plantilla = Nothing

    Set XL = Nothing

    rst.Close

    dbs.Close

    Set rst = Nothing

    Set dbs = Nothing

    DoCmd.Close acForm, "F_ExpPM"

    DoCmd.OpenForm "F_ProgramasEmitidos"

    MsgBox "La exportación se ha guadado en ...\SGRADIO_CAPTAv1.0\tmp_SGRADIO_CAPTAv1.0 EXPORTA", vbInformation + vbSystemModal, "Información"

End Sub