Error al exportar a plantilla de 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=86774
Fecha de impresión: 27/Marzo/2026 a las 02:46
Tema: Error al exportar a plantilla de Excel
Publicado por: joanka
Asunto: Error al exportar a plantilla de Excel
Fecha de publicación: 08/Septiembre/2023 a las 21:01
|
Hola a todos, Me han migrado en la empresa Office2016 a Office365. Tengo una BD donde tengo formularios que exportan datos a plantillas de Excel. Todo funcionaba correctamente hasta la migración. Cuando empieza la exportación me aparece al abrir la plantilla: 'Plantilla.xlsx' está bloqueado para editarlo por 'nombre de usuario'(o sea yo mismo). Abra el documento como solo lectura o ... etc. Me realiza la exportación, me guarda el archivo en la ubicación definida con el nombre que quiero. Al abrirla aparece totalmente vacía (sin hoja). Luego abro manualmente la plantilla y me indica que la última vez que se abrió ocurrió un error grave. He mirado las referencias, en la depuración no me da ningún error. Dudo si es fallo del código VBA de exportar (que no haya cambiado algo en Excel) o del mismo Excel. He revisado el centro de confianza y veo que está configurado como antes, o eso me parece a mi. Agradecería vuestra ayuda, gracias
 |
Respuestas:
Publicado por: joanka
Fecha de publicación: 08/Septiembre/2023 a las 21:29
|
El código resumido que uso es: Option Compare Database 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 Sub Excel() Me.Refresh On Error Resume Next Dim DEPARTAMENTO As String, RESPONSABLE As String, numsolicitud As String, FECHA As String Dim rutaPlantilla As String Dim nuevoExcel As String Dim miexcel As Object Dim miHoja As Object Dim msg As String If IsNull(Me.RESPONSABLE) Then MsgBox "El campo 'RESPONSABLE' es obligatorio.", vbOKOnly + vbExclamation, "ATENCIÓN" Me.RESPONSABLE.SetFocus Exit Sub ElseIf IsNull(Me.FECHA) Then MsgBox "El campo 'FECHA' es obligatorio.", vbOKOnly + vbExclamation, "ATENCIÓN" Me.FECHA.SetFocus Exit Sub Else Dim c1 As String Dim c2 As String Dim Descripcion1 As String Dim Descripcion2 As String DEPARTAMENTO = Nz(Me.DEPARTAMENTO.Value, "") RESPONSABLE = Nz(Me.RESPONSABLE.Value, "") numsolicitud = Nz(Me.numsolicitud.Value, "") c1 = Nz(Me.c1.Value, "") c2 = Nz(Me.c2.Value, "") Descripcion1 = Nz(Me.Descripcion1.Value, "") Descripcion2 = Nz(Me.Descripcion2.Value, "") NOMBRE = Nz(Me.RESPONSABLE.Value, "") FECHA = Nz(Me.FECHA.Value, "") nuevoExcel = "S:\Solicitudes\Solicitudesnuevas\" rutaPlantilla = Application.CurrentProject.Path & "\PLANTILLAS\Plantilla.xlsx" Call ShellExecute(Me.hwnd, "Open", rutaPlantilla, "", "", 1) Set miexcel = GetObject(rutaPlantilla) Set miHoja = miexcel.Worksheets("Hoja1") With miHoja .Range("d6").Value = DEPARTAMENTO .Range("d7").Value = RESPONSABLE .Range("d8").Value = numsolicitud .Range("c11").Value = c1 .Range("c12").Value = c2 .Range("d11").Value = Descripcion1 .Range("d12").Value = Descripcion2 End With miexcel.Application.DisplayAlerts = False miexcel.SaveAs nuevoExcel & numsolicitud & ".xlsx" MsgBox "El archivo " & (numsolicitud) & ".xlsx " & "se ha guardado", vbInformation + vbSystemModal, "Información" miexcel.Application.DisplayAlerts = True End If Dim milibro As Object Dim esta As Boolean Dim mifichero As String esta = False mifichero = nuevoExcel & numsolicitud & ".xlsx" For Each milibro In miexcel.Application.Workbooks If milibro.FullName = mifichero Then esta = True Else esta = False Exit For End If Next If esta = True Then miexcel.Close Shell ("taskkill /f /im excel.exe") Else miexcel.Close End If End Sub |
Publicado por: joanka
Fecha de publicación: 09/Septiembre/2023 a las 11:39
|
Hola a todos otra vez, he simplificado hasta ver que el problema está en: Me abre la plantilla con: Call ShellExecute(Me.hwnd, "Open", rutaPlantilla, "", "", 1) Pero una vez ejecuta la parte del código: Set miexcel = GetObject(rutaPlantilla) Me indica que el archivo ya está en uso por mi usuario y no deja editarlo. Código: Option Compare Database 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 Comando0_Click() Dim rutaPlantilla As String Dim miexcel As Object 'Cogemos la ruta de la plantilla rutaPlantilla = Application.CurrentProject.Path & "\PLANTILLAS\Plantilla.xlsx" 'Abrimos la plantilla de Excel Call ShellExecute(Me.hwnd, "Open", rutaPlantilla, "", "", 1) 'Capturamos la instancia de Excel para poder operar desde Access Set miexcel = GetObject(rutaPlantilla) End Sub |
Publicado por: joanka
Fecha de publicación: 09/Septiembre/2023 a las 13:27
|
Bueno he conseguido dar con la tecla. Sub Excel() Me.Refresh On Error Resume Next Dim DEPARTAMENTO As String, RESPONSABLE As String, numsolicitud As String, FECHA As String Dim rutaPlantilla As String Dim nuevoExcel As String Dim miexcel As Object Dim miHoja As Object Dim msg As String If IsNull(Me.RESPONSABLE) Then MsgBox "El campo 'RESPONSABLE' es obligatorio.", vbOKOnly + vbExclamation, "ATENCIÓN" Me.RESPONSABLE.SetFocus Exit Sub ElseIf IsNull(Me.FECHA) Then MsgBox "El campo 'FECHA' es obligatorio.", vbOKOnly + vbExclamation, "ATENCIÓN" Me.FECHA.SetFocus Exit Sub Else Dim c1 As String Dim c2 As String Dim Descripcion1 As String Dim Descripcion2 As String 'Cogemos los datos del formulario DEPARTAMENTO = Nz(Me.DEPARTAMENTO.Value, "") RESPONSABLE = Nz(Me.RESPONSABLE.Value, "") numsolicitud = Nz(Me.numsolicitud.Value, "") c1 = Nz(Me.c1.Value, "") c2 = Nz(Me.c2.Value, "") Descripcion1 = Nz(Me.Descripcion1.Value, "") Descripcion2 = Nz(Me.Descripcion2.Value, "") NOMBRE = Nz(Me.RESPONSABLE.Value, "") FECHA = Nz(Me.FECHA.Value, "") 'Asignamos la ruta hasta la carpeta para el nuevo Excel nuevoExcel = "S:\Solicitudes\Solicitudesnuevas\" 'Cogemos la ruta de la plantilla rutaPlantilla = Application.CurrentProject.path & "\PLANTILLAS\Plantilla.xlsx" Set miexcel = CreateObject("Excel.Application") miexcel.Visible = False miexcel.Workbooks.Open rutaPlantilla 'Cogemos la Hoja de la plantilla Set miHoja = miexcel.activeworkbook.Worksheets("Hoja1") 'Operamos sobre la hoja With miHoja .Range("d6").Value = DEPARTAMENTO .Range("d7").Value = RESPONSABLE .Range("d8").Value = numsolicitud .Range("c11").Value = c1 .Range("c12").Value = c2 .Range("d11").Value = Descripcion1 .Range("d12").Value = Descripcion2 End With nuevoExcel = nuevoExcel & numsolicitud & ".xlsx" If Dir(nuevoExcel) <> "" Then If MsgBox("El archivo " & numsolicitud & ".xlsx" & " ya existe, deseas sobreescribirlo?", vbExclamation + vbYesNo, "Sobreescribir archivo") = vbNo Then miexcel.Quit Set miexcel = Nothing Exit Sub End If End If 'Guardamos el Excel con otro nombre miexcel.Application.DisplayAlerts = False miexcel.activeworkbook.SaveAs nuevoExcel miexcel.Application.DisplayAlerts = True miexcel.activeworkbook.Close False miexcel.Quit Set miexcel = Nothing MsgBox "El archivo " & (numsolicitud) & ".xlsx " & "se ha guardado en S:\Solicitudes\Solicitudesnuevas\", vbInformation + vbSystemModal, "Información" End If Dim milibro As Object Dim esta As Boolean Dim mifichero As String esta = False mifichero = nuevoExcel & numsolicitud & ".xlsx" For Each milibro In miexcel.Application.Workbooks If milibro.FullName = mifichero Then esta = True Else esta = False Exit For End If Next If esta = True Then miexcel.activeworkbook.Close False miexcel.Quit Set miexcel = Nothing Else miexcel.activeworkbook.Close False miexcel.Quit Set miexcel = Nothing End If End Sub Gracias!
|