Rellenar plantilla en Word desde formulario access con un boton

06/12/2013 - 19:12 por jcmhermida | Informe spam
¡ Hola !
Tengo el siguiente código en Visual Basic para rellenar una plantilla en Word y la tabla de detalles me genera las filas necesarias para los registros filtrados pero en cada fila me repite siempre los mismos datos. Que tengo que modificar en el código para que me cambio los datos en la tabla de word

codigo:

Option Compare Database
Option Explicit

'REFERENCIAS NECESARIAS:
'Menú -> Herramientas -> Referencias -> Microsoft Word Object Library

'Ejemplo:
'' Dim informe As New ClaseInformeWord
'' Dim filtro As String
''
'' filtro = "cliente_id=" & Me.cliente_id
''
'' Call informe.Abrir("informe_cliente_pedidos.dot")
'' Call informe.Ejecutar("tabla_clientes", filtro)
'' Call informe.EjecutarTablaDetalles(2, "consulta_pedidos", filtro)
'' Call informe.Cerrar
''
'' Set informe = Nothing

Private app_word As Word.Application
Private documento_word As Word.Document

Private Sub Class_Initialize()
'Nada
End Sub

Private Sub Class_Terminate()
Call Cerrar
End Sub

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, 100)
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
'If 0 <> InStr(LCase(field.Name), "importe") Then
'valor = Format(Nz(rs(field.Name), 0), "#,##0.00")
'Else
'valor = rs(field.Name) & ""
'End If
'campo = Replace(campo, "[" & field.Name & "]", valor)
'Next
'celda.Range.Text = campo
Next

'Call SysCmd(acSysCmdUpdateMeter, rs.PercentPosition) 'Fallas porque es dbOpenForwardOnly
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

Muchas gracias por adelantado
 

Preguntas similares