Function WordOutput(FilePath As String, _
                    strSQL As String, _
                    strWhere As String, _
                    Mode As Byte) As String
' Подпрограмма предназначена для экспорта информации из запроса
' в отчет. Условие одно, запрос должен содержать ровно одну запись
' Все остальные варианты отвергаются
' Параметры: FilePath - путь к файлу шаблона
'            strSQL - имя внешнего запроса или сам SQL запрос
'            strWhere - Параметры для выборки
'            Mode - Вывода результатов:
'                    1  - предварительный просмотр
'                   2 - печать
' Выход: результат операции или при сохранении на диске - имя файла
'
    Dim wrdObj As Object
    Dim rst As New ADODB.Recordset
    Dim fld As ADODB.Field
    Dim Source As String
    Dim Pole As String
    Dim i As Integer
    If Right(FilePath, 5) = "\.dot" Then Exit Function
    On Error Resume Next
    ' Проверка на присутствие данных
    If Len(Trim(FilePath)) =  0  Then Exit Function
    If Len(Trim(strSQL)) =  0  Then Exit Function
    ' Открытие объекта - Microsoft Word (любой версии)
    Set wrdObj = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set wrdObj = CreateObject("Word.Application")
    End If
    wrdObj.Visible = False
    ' Открытие шаблона документа и проверка на его присутствие
    wrdObj.Documents.Add FilePath
    If Err.Number <>  0  Then
        Err.Clear
        MsgBox  "Отсутствует файл шаблона документа,"  & vbCrLf & _
               FilePath, vbCritical + vbOKOnly,  "Ошибка" 
        wrdObj.Quit
        Set wrdObj = Nothing
        Exit Function
    End If
    ' Открытие данных и проверка на их присутствие
    If Len(Trim(strWhere)) = 0 Then
        rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Else
        rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        rst.Filter = strWhere
        If Err.Number <> 0 Then
            Err.Clear
            MsgBox "Неправильно задана выборка", vbCritical + vbOKOnly, "Ошибка"
            wrdObj.Quit
            Set wrdObj = Nothing
            Exit Function
        End If
        If rst.RecordCount Then
            rst.MoveLast
        Else
            MsgBox "Ни одна запись не удовлетворяет условию выборки", _
                   vbCritical + vbOKOnly, "Ошибка"
            wrdObj.Quit
            Set wrdObj = Nothing
            Exit Function
        End If
    End If
    ' Перебор полей (с предварительной проверкой на присутствие меток в док-те)
    With wrdObj.ActiveDocument.Bookmarks
        i =  1 
        Do Until .Count =  0 
            Pole = Trim(.Item(i).Name)
            ' Заполнение полей, если они присутствуют в запросе
            .Item(i).Range.Text = CStr(rst.Fields(Trim(Pole)).Value) & ""
            ' Заметает следы своей деятельности в документе
            .Item(i).Delete
        Loop
    End With
    ' Обработка "Спецзнаков"
    For Each fld In rst.Fields
        With wrdObj.ActiveWindow.Selection.Find
            .Text = "[" & fld.Name & "]"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = 1
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        If wrdObj.ActiveWindow.Selection.Find.Execute Then
            wrdObj.ActiveWindow.Application.Keyboard (1049)
            If Len(Str(rst.Fields(fld.Name).Value)) > 0 Then
                wrdObj.ActiveWindow.Selection.TypeText Text:=rst.Fields(fld.Name).Value & ""
            Else
                wrdObj.ActiveWindow.Selection.TypeText Text:=" "
            End If
        End If
        With wrdObj.ActiveWindow.Selection.Find
            .Text = "[" & fld.Name & "]"
            .Replacement.Text = rst.Fields(fld.Name).Value & ""
            .Forward = True
            .Wrap = 1
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        wrdObj.ActiveWindow.Selection.Find.Execute Replace:=2 'wdReplaceAll
    Next
    rst.Close
    Select Case Nz(Mode,  1 )
        Case  1 
            ' Предварительный просмотр
            wrdObj.Visible = True
            wrdObj.SetFocus
        Case 2
            ' Печать на текущий принтер
            wrdObj.ActiveDocument.PrintOut
            wrdObj.ActiveDocument.Close ( 0 )
            MsgBox  "Печать закончена" , vbInformation + vbOKOnly
    End Select
    Set rst = Nothing
    Set wrdObj = Nothing
End Function