Function EscribeWord(ByVal Consulta As String, Titulo As String)
    Dim appWord As New Word.Application
    Dim docWord As New Word.Document
    Dim Parrafo As Word.Paragraph
    Dim strFinalDoc As String
    Dim RS As ADODB.Recordset
    Dim Lineas As Integer
    Dim I As Integer

    Dim rngCurrent As Word.Range
    Dim ContadoR As Integer
    Dim Funcionario As String
    Dim Clasificacion As String
    
    On Error GoTo Error_AccessToWord
    
    Lineas = 0
    strFinalDoc = SERVER & "\BD\Libro.doc"
    
    
        Set RS = New ADODB.Recordset
        Set RS = DemiData.cnCentral.Execute(Consulta)
        If RS.RecordCount = 0 Then
            frmAviso.lblTexto = "No existen datos para generar el archivo"
            frmAviso.cmdCancelar.Visible = False
            frmAviso.cmdAceptar.left = 1920
            frmAviso.Show 1
        Else
            appWord.Visible = True
            Set docWord = appWord.Documents.Add(strFinalDoc)
            Set rngCurrent = docWord.Content
            With rngCurrent
            
                .InsertAfter Titulo
                Funcionario = ""
                Clasificacion = ""
                For ContadoR = 1 To RS.RecordCount
                    If (Funcionario <> inCaseNull(RS!Nombre)) Or (Clasificacion <> inCaseNull(RS!Clasificacion)) Then
                       If Lineas <> 0 Then
                        For I = Lineas To 48
                            .InsertAfter vbCrLf
                        Next
                        End If
                        Lineas = 0
                        
                        Funcionario = inCaseNull(RS!Nombre)
                        Clasificacion = inCaseNull(RS!Clasificacion)
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        
                        .Bold = True  'En negrilla
                        .InsertAfter "FUNCIONARIO: "
                        .Bold = False
                        .InsertAfter inCaseNull(RS!Nombre)
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .Bold = True
                        
                        .InsertAfter "PENSAMIENTO POLITICO "
                        .Bold = False
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter inCaseNull(RS!Clasificacion)
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .InsertAfter vbCrLf
                        .Bold = True
                        
                    End If
                    .Bold = False
                   
                    .InsertAfter "Fecha: " & inCaseNull(RS!Fecha) & vbCrLf
                    .InsertAfter "Clasificacion: " & inCaseNull(RS!Clasificacion) & " - " & inCaseNull(RS!Clasificacion2) & " - " & inCaseNull(RS!Clasificacion3) & vbCrLf
                    .InsertAfter "Lugar: " & inCaseNull(RS!Municipio) & vbCrLf
                    .InsertAfter "Medio:" & inCaseNull(RS!Medio) & " - " & inCaseNull(RS!Medio1) & " - " & inCaseNull(RS!Medio2) & vbCrLf
                    .InsertAfter "Concepto:" & inCaseNull(RS!QueDijo) & vbCrLf
                    .InsertAfter vbCrLf
                    Dim Num As Integer
                    Num = Len("Concepto:" & inCaseNull(RS!QueDijo)) / 85
                    
                    If Num < 1 Then
                        Num = 0
                    Else
                        Num = Num - 1
                    End If
                    If Lineas >= 8 Then
                        Lineas = Lineas + 6 + Num
                    Else
                        Lineas = Lineas + 8 + Num
                    End If
                    If Lineas >= 47 Then
                        Lineas = Lineas - 47
                    End If
                    RS.MoveNext
                Next ContadoR
            End With
        End If
   
   Set rngCurrent = Nothing
   RS.Close
   Set RS = Nothing
   
   Exit Function
   
Error_AccessToWord:
   
   Beep
   MsgBox "Error de automatizacion:" & vbCrLf & Err.Description, vbCritical, "AVISO"
   Exit Function

End Function

Pienso primero luego programo