Crear PDF y guardar en Datos Adjuntos
Tengo creado un informe que se abre por el registro activo de un formulario. Desde ese formulario necesito que me cree un archivo PDF de manera oculta y lo guarde en los datos adjuntos. El nombre que debe darle al archivo PDF que genere, debe ser un numero propio del registro que tiene 4 dígitos y añada 3 dígitos mas según numero de archivos tenga ya guardado ese registro. Por ejemplo si el numero de registro es 1145 y es el primer PDFque se crea, el nombre del archivo seria 1145001, y si fuera por ejemplo el cuarto 1145004.
Necesita una tabla temporal para almacenar los nombres de archivos que retorne la función, una función para obtener el siguiente archivo y una función para adjuntar el archivo. Le preparé este ejemplo.
TABLAS
Esta tabla se actualiza cada vez que se ejecute la función.
FORMULARIO
REPORTE
CÓDIGO DEL EVENTO DESPUES DE ACTUALIZAR DEL CUADRO COMBINADO
Private Sub cboNumero_AfterUpdate() On Error GoTo hay_error Dim strSgte As String Dim strArchivoAdj As String strSgte = sigtePDF(CurrentProject.Path, Me.cboNumero.Column(1), "PDF") strArchivoAdj = CurrentProject.Path & "\" & strSgte & ".PDF" DoCmd.OpenReport "rptInforme", acViewPreview, , "[nroreg] = " & Me.cboNumero.Column(1), acHidden DoCmd.OutputTo acOutputReport, "rptInforme", acFormatPDF, strArchivoAdj, False DoCmd.Close acReport, "rptInforme" Call Adjunta("tblclientes", "archivo", "nroreg", Me.cboNumero.Column(1), strArchivoAdj) If Err.Number = 0 Then MsgBox "Archivo PDF creado satisfactoriamente", vbInformation, "Le informo" End If hay_error_exit: Exit Sub hay_error: MsgBox "Ocurrió el error " & Err.Number & " - " & Err.Description, vbCritical, "Error..." Resume hay_error_exit End Sub
CÓDIGO DE LA FUNCION sigtePDF
Public Function sigtePDF(mpath As String, lnregistro As Long, mextension As String) As String 'Función obtener el siguiente archivo con base en el número de registro 'y la extensión Dim MiPc, Carpeta, Archivos, archivo Dim miext As String Dim cant_tem As Long CurrentDb.Execute "DELETE FROM tblTemporal" Set MiPc = CreateObject("Scripting.FileSystemObject") Set Carpeta = MiPc.GetFolder(mpath) Set Archivos = Carpeta.Files For Each archivo In Archivos miext = MiPc.GetExtensionName(archivo.Name) If miext = mextension And mid(archivo.Name, 1, 4) = lnregistro Then CurrentDb.Execute "INSERT INTO tblTemporal(archivo) VALUES('" & mid(archivo.Name, 1, 7) & "')" End If Next cant_tem = Nz(DMax("[archivo]", "tblTemporal")) If cant_tem = 0 Then sigtePDF = lnregistro & "001" & "." & mextension Else sigtePDF = cant_tem + 1 & "." & mextension End If End Function
CÓDIGO DE LA FUNCIÓN ADJUNTA
Public Function Adjunta(strTabla, strCampoAdjunto, strIDcampo As String, i As Long, strArchivo As String) Dim cdb As DAO.Database, rstMain As DAO.Recordset, rstAttach As DAO.Recordset2, _ fldAttach As DAO.Field2 Set cdb = CurrentDb Set rstMain = cdb.OpenRecordset("SELECT " & strCampoAdjunto & " FROM " & strTabla & " where " & strIDcampo & "= " & i, dbOpenDynaset) rstMain.Edit Set rstAttach = rstMain(strCampoAdjunto).Value rstAttach.AddNew Set fldAttach = rstAttach.Fields("FileData") fldAttach.LoadFromFile strArchivo rstAttach.Update rstAttach.Close Set rstAttach = Nothing rstMain.Update rstMain.MoveNext rstMain.Close Set rstMain = Nothing Set cdb = Nothing End Function
EJEMPLO DE ARCHIVOS
Utilicé funciones para poderlas llamar desde cualquier formulario.
Personalmente no utilizo archivos adjuntos, son un desastre. Preparé este ejemplo para dar respuesta a su pregunta, requiere conocimiento avanzado de VBA. Si quiere el ejemplo lo puede solicitar a [email protected] favor anotar la consulta en el asunto.
Si no quiere utilizar tabla temporal y en su lugar un array, puede reemplazar la función sigtePDF() por la siguiente:
Public Function sigtePDF(mpath As String, lnregistro As Long, mextension As String) As String 'Función obtener el siguiente archivo con base en el número de registro 'y la extensión 'Por ejemplo: Archivos ... ' 1145001.PDF ' 1145002.PDF ' Al llamar la función se ' obtiene el siguiente 1145003.PDF ' En donde 1145 es el código del alumno o el ID ' 'Elaborado por: EDUARDO PÉEZ FERNÁNDEZ 'Fecha: 24/02/2022 'Versión 2.0 'Parámetros: ' mpath ----> Ruta donde se guardan los PDF ' lnregistro ----> Código del registro (alumno, empleado etc) ' mextension ----> Extensión del archivo, por ejemplo. "PDF","TXT" ' 'Ejemplo de llamada: ' ' sigtePDF("D:\TodoExpertos\AdjuntarArchivo",1145,"PDF") ' Dim MiPc, Carpeta, Archivos, archivo Dim miext As String 'Dim cant_tem As Long 'Decomente esta linea si usa tabla temporal '************************************** 'Comente estas linea para usar tabla temporal Dim strTem As String Dim miArray() As String '************************************** ' Descomentar para usar tabla temporal ' CurrentDb.Execute "DELETE FROM tblTemporal" Set MiPc = CreateObject("Scripting.FileSystemObject") Set Carpeta = MiPc.GetFolder(mpath) Set Archivos = Carpeta.Files For Each archivo In Archivos miext = MiPc.GetExtensionName(archivo.Name) If miext = mextension And mid(archivo.Name, 1, 4) = lnregistro Then 'Comentar la siguiente para usar tabla strTem = strTem & mid(archivo.Name, 1, 7) & "," 'Descomentar para usar tabla ' CurrentDb.Execute "INSERT INTO tblTemporal(archivo) VALUES(" & mid(archivo.Name, 1, 7) & ")" End If Next 'Documente estas lineas si utiliza tabla temporal '**************************************************** If strTem <> "" Then 'Retiro la coma (,) strTem = Left(strTem, Len(strTem) - 1) End If If Len(strTem) = 0 Then 'Ya habia pdf sigtePDF = lnregistro & "001" & "." & mextension Else miArray = Split(strTem, ",") sigtePDF = miArray(UBound(miArray)) + 1 & "." & mextension End If '***************************************************** 'Descomentar si utiliza la tabla temporal y NO Array 'cant_tem = Nz(DMax("[archivo]", "tblTemporal")) 'Descomentar para usar tabla temporal 'If cant_tem = 0 Then ' sigtePDF = lnregistro & "001" & "." & mextension 'Else ' sigtePDF = cant_tem + 1 & "." & mextension 'End If End Function
Es más practica esta otra forma, ya es cuestión de gusto.
Otra función si quiere utilizar DIR() en lugar de FileSystem :
Public Function Siguiente_PDF(mpath As String, lnregistro As Long, mextension As String) As String 'Función obtener el siguiente archivo con base en el número de registro 'y la extensión. Ejemplo usando DIR() 'Por ejemplo: Archivos ... ' 1145001.PDF ' 1145002.PDF ' Al llamar la función se ' obtiene el siguiente 1145003.PDF ' En donde 1145 es el código del alumno o el ID ' 'Elaborado por: EDUARDO PÉEZ FERNÁNDEZ 'Fecha: 24/02/2022 'Versión 2.0 'Parámetros: ' mpath ----> Ruta donde se guardan los PDF ' lnregistro ----> Código del registro (alumno, empleado etc) ' mextension ----> Extensión del archivo, por ejemplo. "PDF","TXT" ' 'Ejemplo de llamada: ' ' Siguiente_PDF("D:\TodoExpertos\AdjuntarArchivo",1145,"PDF") Dim archivo As String Dim strRuta As String Dim strTem As String Dim miArray() As String strRuta = mpath & "\" archivo = Dir(strRuta & lnregistro & "*." & mextension) Do While Len(archivo) > 0 strTem = strTem & mid(archivo, 1, 7) & "," archivo = Dir Loop If strTem <> "" Then 'Retiro la coma (,) strTem = Left(strTem, Len(strTem) - 1) End If If Len(strTem) = 0 Then 'No hay pdf Siguiente_PDF = lnregistro & "001" & "." & mextension Else miArray = Split(strTem, ",") Siguiente_PDF = miArray(UBound(miArray)) + 1 & "." & mextension End If End Function
Si utiliza esta función cambie el nombre sigtePDF por Siguiente_PDF.
- Compartir respuesta