Mis conocimientos en VBA es para andar por casa por lo que ruego me ayudeis en la medida que podais ya que en estos momentos las tareas las estoy haciendo a pedal y es... mientras que con la aplicacion era apretar el botoncito... hazte cargo. Agradezco de antemano vuestra ayuda ya que es un tema para mi bastante importante. Gracias fenomenos.
Private Sub Junta_Click()
If Not IsNull(IdClinica) Or Me!IdClinica <> "" Then
Dim Informe As New ClaseInformeWord
Dim filtro As String
filtro = "IdClinica=" & Me.IdClinica
Call Informe.Abrir("\Documentacion\Certificados\Empresas Nuevas Junta.dot")
Call Informe.Ejecutar("Consulta_Prevencion_Principal", filtro)
Call Informe.EjecutarTablaDetalles(2, "Consulta_Acuerdo_Principal_Anexo_Nuevas", filtro)
Call Informe.Cerrar
Set Informe = Nothing
Else
DoCmd.OpenForm "MensajeError", , , , , , "El Registro está en Blanco"
End If
End Sub
Option Compare Database
Option Explicit
Private app_word As Word.Application
Private documento_word As Word.Document
Public Function Abrir(ByVal plantilla_word As String)
Dim ruta_actual As String
Set app_word = New Word.Application
app_word.Visible = False
If plantilla_word = "" Then
Set documento_word = app_word.Documents.Add()
Else
ruta_actual = left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
Set documento_word = app_word.Documents.Add(ruta_actual & plantilla_word)
End If
End Function
Public Function Cerrar()
On Error Resume Next
app_word.Visible = True
Set app_word = Nothing
Set documento_word = Nothing
End Function
Public Function Ejecutar( _
ByVal consulta As String, _
Optional ByVal filtro As String = "" _
) As Boolean
On Error GoTo Errores
Call SysCmd(acSysCmdInitMeter, "Exportando a Word: " & consulta, 400)
DoCmd.Hourglass True
Dim rs As DAO.Recordset
Dim field As DAO.field
If filtro <> "" Then consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
If rs.BOF And rs.EOF Then
'Nada
Else
For Each field In rs.Fields
With app_word.Selection.Find
.ClearFormatting
.Text = "[" & UCase(field.Name) & "]"
With .Replacement
.ClearFormatting
.Text = rs(field.Name) & ""
End With
Call .Execute(Replace:=Word.WdReplace.wdReplaceAll)
End With
Next
End If
Ejecutar = True
Salida:
Call SysCmd(acSysCmdRemoveMeter)
DoCmd.Hourglass False
Exit Function
Errores:
MsgBox Err.Description, vbCritical, "Ejecutar"
Resume Salida
End Function
Public Function EjecutarTablaDetalles( _
ByVal num_tabla As Integer, _
ByVal consulta As String, _
Optional ByVal filtro As String = "" _
) As Boolean
On Error GoTo Errores
Call SysCmd(acSysCmdInitMeter, "Exportando a Word: " & consulta, 100)
DoCmd.Hourglass True
Dim rs As DAO.Recordset
Dim field As DAO.field
Dim tabla As Word.Table
Dim ultima_fila As Word.Row, nueva_fila As Word.Row
Dim celda As Word.Cell
Dim campo As String, Valor As String
If filtro <> "" Then consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
Set tabla = documento_word.Tables(num_tabla)
If rs.BOF And rs.EOF Then
'Nada
Else
Do Until rs.EOF
Set ultima_fila = tabla.Rows(tabla.Rows.Count)
Set nueva_fila = tabla.Rows.Add
For Each celda In ultima_fila.Cells
'Duplicar la última fila en la nueva
campo = celda.Range.Text
campo = left(campo, Len(campo) - 2) 'Eliminar vbCrLf del final
nueva_fila.Cells(celda.ColumnIndex).Range.Text = campo
'Poner los valores
For Each field In rs.Fields
Valor = rs(field.Name) & ""
campo = Replace(campo, "[" & field.Name & "]", Valor)
Next
celda.Range.Text = campo
Next
rs.MoveNext
Loop
End If
'Borrar la última fila
tabla.Rows(tabla.Rows.Count).Delete
EjecutarTablaDetalles = True
Salida:
Call SysCmd(acSysCmdRemoveMeter)
DoCmd.Hourglass False
Exit Function
Errores:
MsgBox Err.Description, vbCritical, "EjecutarTablaDetalles"
Resume Salida
End Function