Tengo este ejemplo. Un poco extenso pero funciona. Está en versión 2003. Ojalá te sirva. Debe haber previamente creado un documento word. Preguntame, puedo ayudarte.
Dim Word As New Word.Application
Dim
Nota As Word.Document
Dim Tabla As
Word.Table
Dim
NombreArchivo As String
Dim myRange As Object
Dim
Fila As Integer
Public
Function NotaSimple(IdOCO
As Long) As Boolean
NotaSimple = False
Directorio =
DLookup("Path", "Parametros", "IdPath = 1")
FOCO
= Nz(DLookup("OCO", "OCOs", "IdOCO = " &
IdOCO), "0")
If
FOCO = "0" Then
MsgBox "No existe la OCO"
Exit Function
End
If
FExpediente = Nz(DLookup("NroExpediente", "OCOs",
"IdOCO = " & IdOCO), "N/D")
FFechaExpediente = Nz(DLookup("FechaExpediente",
"OCOs", "IdOCO = " & IdOCO), "N/D")
Word.Visible = True
Set Nota = Word.Documents.Open(FileName:=Directorio & "Notas\NotaModelo.doc",
ReadOnly:=True)
NroOCO =
DLookup("OCO", "OCOs", "IdOCO = " & IdOCO)
FEmpresa = DLookup("Empresa", "OCOs", "IdOCO =
" & IdOCO)
NroNota = InputBox("Ingresar Nro de nota")
If
FEmpresa = "Farma KD" Then
NombreArchivo = Directorio & "Notas\Nota "
& NroNota & " OC " & NroOCO & "-" &
Nz(DLookup("Barra", "OCOs", "IdOCO = " &
IdOCO), "0") & ".doc"
Else
NombreArchivo = Directorio & "LAFKEN\Notas\Nota
" & NroNota & " OC " & NroOCO & "-"
& Nz(DLookup("Barra", "OCOs", "IdOCO = "
& IdOCO), "0") & ".doc"
End
If
NroOCO = NroOCO & "/" & Nz(DLookup("Barra",
"OCOs", "IdOCO = " & IdOCO), "0")
Nota.SaveAs NombreArchivo
Set myRange = Word.ActiveDocument.Content
Fila
= 0
Set Tabla =
Nota.Tables(1)
'*****************************************************************************
'fecha
'*****************************************************************************
'With myRange.Find
With Nota.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text
= "#Fecha#"
.Replacement.Text = Date
.Execute Replace:=wdReplaceAll
End
With
'*****************************************************************************
'OCO
'*****************************************************************************
'With myRange.Find
With Nota.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text
= "#OC1#"
.Replacement.Text = NroOCO
.Execute Replace:=wdReplaceAll
End
With
'*****************************************************************************
'OCO
'*****************************************************************************
'With myRange.Find
With Nota.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#OC2#"
.Replacement.Text = NroOCO
.Execute Replace:=wdReplaceAll
End With
'*****************************************************************************
'NroNota
'*****************************************************************************
' With myRange.Find
With Nota.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#nronota#"
.Replacement.Text = NroNota
.Execute Replace:=wdReplaceAll
End With
'*****************************************************************************
'Tabla de datos
'*****************************************************************************
rs.Open "Select * from
Paso5Nota where IdOCO = " & IdOCO & " Order By idestado,
idfactura", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
If rs.EOF And rs.BOF Then
MsgBox "No
hay renglones para OCO: " & FOCO
GoTo Salida
End If
'**************************************************
'Primer lectura
'**************************************************
rs.MoveFirst '***** lee el
primero
FTotalizado = 0
Guarda
FIdEStado = rs("IdEstado")
FIdFactura = rs("IdFactura")
FIdEstadoAnterior = FIdEStado
FIdFacturaAnterior = FIdFactura
FMontoFactura = 0
FQFactura = 0
FMontoLote = 0
FQLote = 0
FMonto = 0
' EstadoFacturaDistintos
Do While Not rs.EOF
rs.MoveNext '**** lee siguiente
If rs.EOF Then
EstadoFacturaDistintos
LineaATabla
Exit Do
End If
If Not rs.EOF Then FIdEStado =
rs("IdEstado")
If Not rs.EOF Then FIdFactura =
rs("IdFactura")
If FIdEStado = FIdEstadoAnterior And
FIdFactura = FIdFacturaAnterior And Not rs.EOF Then
ALote = ALote & vbCrLf &
rs("Lote")
AFechaVto =
AFechaVto & vbCrLf & Nz(rs("FechaVto"))
AMontoLote =
CCur(AMontoLote) + rs("MontoLote")
AQLote = CInt(AQLote) +
rs("CantidadLote")
End If
If Not FIdEStado = FIdEstadoAnterior
And Not FIdFactura = FIdFacturaAnterior And Not rs.EOF Then
EstadoFacturaDistintos
LineaATabla
FMontoFactura = CCur(Nz(FMontoFactura, 0)) + CCur(AMontoFactura)
FQFactura = CInt(FQFactura) + CInt(AQFactura)
FIdEstadoAnterior
= FIdEStado
FIdFacturaAnterior = FIdFactura
End If
If Not FIdEStado = FIdEstadoAnterior
And FIdFactura = FIdFacturaAnterior And Not rs.EOF Then
IdemFactura
LineaATabla
FIdEstadoAnterior = FIdEStado
End If
If FIdEStado = FIdEstadoAnterior And
Not FIdFactura = FIdFacturaAnterior And Not rs.EOF Then
IdemEstado
LineaATabla
FIdFacturaAnterior = FIdFactura
End If
Loop
'With myRange.Find
With Nota.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#Totalizado#"
.Replacement.Text = Format(FTotalizado,
"##,##0.00")
.Execute Replace:=wdReplaceAll
End With
'*****************************************************************************
'Terminar
'*****************************************************************************
Nota.SaveAs NombreArchivo
Salida:
' Nota.Close
' Set
Nota = Nothing
If vbYes = MsgBox("¿Cierra Word?", vbYesNo) Then
Nota.Close
Set Nota = Nothing
Word.Quit
End If
Respuesta = CISave("NroNota", "OCOS", "IdOCO =
" & IdOCO, NroNota)
Exit Function
Errores:
If Err.Number = 94 Then
MsgBox "Falta
completar datos: Nro remito, fecha etc completar y repetir la operación"
Word.Quit
Set Nota = Nothing
Exit Function
End If
MsgBox Err.Number & " " &
Err.Description
Nota.Close
Set Nota = Nothing
Word.Quit
NotaSimple = True
Public Sub LineaATabla()
Tabla.Cell(Tabla.Rows.Count + Fila, 1).Range.InsertAfter FNroFactura
Tabla.Cell(Tabla.Rows.Count + Fila, 2).Range.InsertAfter "$ "
& Format(FMonto, "##,##0.00")
Tabla.Cell(Tabla.Rows.Count + Fila, 3).Range.InsertAfter FDescripcion
Tabla.Cell(Tabla.Rows.Count + Fila, 4).Range.InsertAfter FQ 'Cantidad
Tabla.Cell(Tabla.Rows.Count + Fila, 5).Range.InsertAfter FAfiliado
Tabla.Cell(Tabla.Rows.Count + Fila, 6).Range.InsertAfter FDelegacion
Tabla.Cell(Tabla.Rows.Count + Fila, 7).Range.InsertAfter FNroRemito
Tabla.Cell(Tabla.Rows.Count + Fila, 8).Range.InsertAfter FLote
Tabla.Cell(Tabla.Rows.Count + Fila, 9).Range.InsertAfter FFechaVto
Tabla.Cell(Tabla.Rows.Count + Fila, 10).Range.InsertAfter FRemitoFactura
FTotalizado =
Nz(CCur(FTotalizado), 0) + Nz(CCur(FMonto), 0)
If Not rs.EOF Then
Tabla.Rows.Add
End
Sub
Public Sub LineaATabla()
Tabla.Cell(Tabla.Rows.Count
+ Fila, 1).Range.InsertAfter FNroFactura
Tabla.Cell(Tabla.Rows.Count + Fila, 2).Range.InsertAfter "$ "
& Format(FMonto, "##,##0.00")
Tabla.Cell(Tabla.Rows.Count + Fila, 3).Range.InsertAfter FDescripcion
Tabla.Cell(Tabla.Rows.Count + Fila, 4).Range.InsertAfter FQ 'Cantidad
Tabla.Cell(Tabla.Rows.Count + Fila, 5).Range.InsertAfter FAfiliado
Tabla.Cell(Tabla.Rows.Count + Fila, 6).Range.InsertAfter FDelegacion
Tabla.Cell(Tabla.Rows.Count + Fila, 7).Range.InsertAfter FNroRemito
Tabla.Cell(Tabla.Rows.Count + Fila, 8).Range.InsertAfter FLote
Tabla.Cell(Tabla.Rows.Count + Fila, 9).Range.InsertAfter FFechaVto
Tabla.Cell(Tabla.Rows.Count + Fila, 10).Range.InsertAfter FRemitoFactura
FTotalizado = Nz(CCur(FTotalizado),
0) + Nz(CCur(FMonto), 0)
If Not rs.EOF Then
Tabla.Rows.Add
Poner en pie de página (de encabezado)
ActiveWindow.ActivePane.View.SeekView
= wdSeekCurrentPageFooter
Selection.TypeText Text:="Nro
Presupuesto: " & Format(IdSolicitud, "000")
ActiveWindow.ActivePane.View.SeekView
= wdSeekMainDocument