Imprimir página | Cerrar ventana

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

Impreso de: Foro de Access y VBA
Categoría: Access y VBA
Nombre del foro: Access y VBA
Descripción del foro: Foro de programacion en Access (Con código y sin código)
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=86935
Fecha de impresión: 26/Marzo/2026 a las 19:25


Tema: error en código de exportación de consulta a excel
Publicado por: carlosd
Asunto: error en código de exportación de consulta a excel
Fecha de publicación: 27/Mayo/2024 a las 18:46
Saludoos amigos, tengo este código que me exporta una consulta de access a un libro de excel que tiene una plantilla:

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

A veces me da este error:

Se ha producido el error '424' en tiempo de ejecución:
Se requiere un objeto.

en esta línea: 
Set miArchivo = GetObject(nuevoExcel & "ProdMusicalv1.0 " & vNombrePrograma & ".xls")

Si lo restablezco y vuelvo a ejecutar me da este error entonces:

Se ha producido el error '-2147417848 (80010108)' en tiempo de ejecución:
Error de automatización

en esta línea:
 miArchivo.Close SaveChanges:=True

Por mucho que he revisado no encuentro la razón y mis conocimientos no son muy extensos. Cualquier ayuda la agredezco


Respuestas:
Publicado por: Mihura
Fecha de publicación: 27/Mayo/2024 a las 19:24
Hola Carlos:

Esto te sobra:
 
    ' Abrir la plantilla de Excel
    Call ShellExecute(Me.hwnd, "Open", rutaPlantilla, "", "", 1)




Y esto también:

    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

No he analizado el resto, pero tiene buena pinta.




-------------
Jesús Mansilla Castells.
Saludos desde Móstoles.

http://www.accessaplicaciones.com" rel="nofollow - Access Aplicaciones
http://www.tecsys.es" rel="nofollow - Tecsys.es

Publicado por: carlosd
Fecha de publicación: 27/Mayo/2024 a las 20:09
gracias por la ayuda Maestro, lo probé vaias veces y no me dió el erro nuevamente

Publicado por: Mihura
Fecha de publicación: 27/Mayo/2024 a las 20:16
No te puede dar el mismo error, porque esa sentencia deberías haberla eliminado  LOL ... postea el código tal cual lo tienes ahora mismo.




-------------
Jesús Mansilla Castells.
Saludos desde Móstoles.

http://www.accessaplicaciones.com" rel="nofollow - Access Aplicaciones
http://www.tecsys.es" rel="nofollow - Tecsys.es

Publicado por: carlosd
Fecha de publicación: 27/Mayo/2024 a las 20:23
yo le dje que no me había dado el error después de comentar esas líneas, no que ma había dado el error, de todas formas ahí va

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\PlantillaTI.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:="Carlos1906*2023", AllowFiltering:=True 'Proteger
    .ActiveWorkbook.SaveAs nuevoExcel & "ProdMusicalv1.0 " & vNombrePrograma & ".xls"
    .ActiveWorkbook.Close SaveChanges:=False
    .DisplayAlerts = True
    .Quit
    
    End With
    
    'Dim miArchivo As Object
    'Set miArchivo = GetObject(nuevoExcel & "ProdMusicalv1 " & vNombrePrograma & ".xls")
    'miArchivo.Close SaveChanges:=True
    '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

Publicado por: Mihura
Fecha de publicación: 27/Mayo/2024 a las 20:28
Perdón ... entendí lo contrario de lo que escribiste.
Ouch

Necesito vacaciones .... LOL

Cierro el hilo.


-------------
Jesús Mansilla Castells.
Saludos desde Móstoles.

http://www.accessaplicaciones.com" rel="nofollow - Access Aplicaciones
http://www.tecsys.es" rel="nofollow - Tecsys.es


Imprimir página | Cerrar ventana