Código para trasladar campo calculado a word

Alba: Si el tema de pasar el Campo a Word desde el Formulario lo tienes resuelto, captura el valor del cuadro de texto del SubFormulario.

Suponiendo que lo llames >> TxtValorAlfa

En el Formulario Principal pones un cuadro de Texto, que puedes ocultar si quieres y que llamaremos TxtDelSubForm

En el evento Despues de actualizar del Formulario Principal

Me.TxtDelSubForm = Nz(Me!NombreDeTuSubFormulario.TxtValorFecha,0)

Luego sigue la metodología de lo que tienes. Saludos >> Jacinto

Alba: Esta línea>>

Me.TxtDelSubForm = Nz(Me!NombreDeTuSubFormulario.TxtValorFecha,0)

Debe ser, por coherencia con los nombres de arriba><

Me.TxtDelSubForm = Nz(Me!NombreDeTuSubFormulario.TxtValorAlfa,0)

Saludos >> Jacinto

No me he explicado bien Jacinto. Los datos que traslada access a word son los datos de una consulta cuyo id coincide con el registro los datos del registro activo en el formulario principal. En el subformulario tengo consultas que muestran campos calculados.

He incluido en la consulta que traslada los datos el campo calculado (suma), pero no me traslada el valor del campo calculado.

Alba: A mi modo de ver si te explcas y a mi me parece entender bien lo que pretendes, pero si ya tienes una parte funcionando, proponerte una metodología completa entiendo que entraría en conflicto con lo que ya tienes y en el peor de los casos te hará replantear todo.

En ese caso, mi sugerencia es que pongas tu BD con datos inventados aquí en un enlace para complementar lo que tengas, o como minimo el código que estás utilizando para intentar ayudarte. Espero tus noticias >> Jacinto

Este es el código que encontré. En el ejemplo había un documento word con dos tablas. Yo quería un sólo documento sin tablas. Lo he solucionado haciendo una consulta con dos consultas.

Módulo de clase:

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

Public Function InformeWord( _
ByVal plantilla_word As String, _
ByVal consulta As String, _
Optional ByVal filtro As String = "" _
) As Boolean
On Error GoTo Errores
'Ejemplo de uso (evento al hacer clic de un botón de comando):
'=InformeWord("informe_cliente.dot";"tabla_clientes";"cliente_id=" & cliente_id)

Dim rs As DAO.Recordset
Dim campo As DAO.field
Dim appWord As Word.Application
Dim documento_word As Word.Document
Dim ruta_actual As String
If filtro <> "" Then
consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
End If
Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
If rs.BOF And rs.EOF Then
'Nada
Else
Set appWord = New Word.Application
appWord.Visible = False
Call SysCmd(acSysCmdInitMeter, "Exportando a Word", 100)
DoCmd.Hourglass True
If plantilla_word = "" Then
Set documento_word = appWord.Documents.Add()
Else
ruta_actual = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
Set documento_word = appWord.Documents.Add(ruta_actual & plantilla_word)
End If
For Each campo In rs.Fields
With appWord.Selection.Find
.ClearFormatting
.Text = "[" & UCase(campo.Name) & "]"
With .Replacement
.ClearFormatting
.Text = rs(campo.Name) & ""
End With
Call .Execute(Replace:=Word.WdReplace.wdReplaceAll)
End With
Next
End If
InformeWord = True
Salida:
On Error Resume Next
appWord.Visible = True
Call SysCmd(acSysCmdRemoveMeter)
DoCmd.Hourglass False
Set appWord = Nothing
Set documento_word = Nothing
rs.Close: Set rs = Nothing
Set campo = Nothing
Exit Function
Errores:
MsgBox Err.Description, vbCritical, "InformeWord"
Resume Salida
End Function

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

Evento botón al hacer click para informe sin tabla detalles

=InformeWord("informe_cliente.dot";"tabla_clientes";"cliente_id=" & [cliente_id])

Evento botón al hacer clic para informe con tabla detalles

Private Sub ComandoInformePedidosClliente_Click()

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
End Sub

Muchas gracias Jacinto

¿Quieres el archivo comprimido con el ejemplo? 2 documentos word y la base de datos o lo ves claro así?

Alba: Aunque el código se vea claro, siempre es mejor trabajar sobre la própia BD con todos los Objetos que me dices, ya que el así aplico la solución directa.

Si tienes facilidad ponla aquí y algún otro te puede aportar otra solución, y si tienes dificultades me la envías a: [email protected]

Mis saludos >> Jacinto