Слияние Word c базой Access

Private Sub КнопкаЗаполнитьДоговор_Click()
 'указываем абсолютный путь к шаблону документа, по которму будем формировать свой документ
    strPathDot = CurrentProject.Path & "\Dot\ДоговорШаблон.dot"
    'указываем под каким именем сохранять создаваемый документ
    'при этом добавляем к имени значение кода записи
    strPathWord = CurrentProject.Path & "\Word" & Me!НомерДоговора & "-" & Me!НомерПриложения & "_ДоговорШаблон.doc"
    Me.Путь = strPathWord
    Call funOutputWord(strPathDot, strPathWord)
End Sub

Option Compare Database
Option Explicit
Dim strPathDot As String, strPathWord As String 'strPathWord-полный путь к документу'
Dim app As Word.Application
 
 
'Вставка текста
Private Sub SelectionText(ByVal SelTxt As Selection, ByVal StrTxt As String, ByVal Bld As Byte, ByVal Otstup As Boolean, Optional ByVal OtstAbsac As Boolean = False)
    With SelTxt
        If Otstup = True Then
            .ParagraphFormat.LeftIndent = 12
        Else
            .ParagraphFormat.LeftIndent = 0
        End If
        Select Case Bld
            Case 1
                .Font.Bold = True
            Case 0
                .Font.Bold = False
        End Select
        If OtstAbsac = True Then
            .ParagraphFormat.SpaceAfter = 3
        Else
            .ParagraphFormat.SpaceAfter = 0
        End If
        .TypeText StrTxt
     End With
End Sub
 
'проверка наличия закладки
Private Function TrueBookmark(ByVal BookmarkName As String, ByVal wa As Word.Document) As Boolean
Dim i As Integer
    For i = 1 To wa.Bookmarks.Count
        If wa.Bookmarks(i).Name = BookmarkName Then
            TrueBookmark = True
            Exit For
        End If
    Next i
End Function
 
'функция выгрузки в Word значений полей формы через закладки в шаблоне
Function funOutputWord(strPathDot As String, strPathWord As String) As Boolean
On Error GoTo Err_
 
Dim DlgUser As Integer, i As Long
 
    'проверяем наличие софрмированного ранее документа
    If Dir(strPathWord) <> "" Then 'если нашелся документ по заданому в strPathWord полному пути (вместе с именем)
        DlgUser = MsgBox("Документ с таким именем ранее уже был создан. Заменить его?", vbYesNo, "admin")
        If DlgUser = vbNo Then 'если пользователь выбрал Нет - то открываем прежний вариант документа
            Set app = CreateObject("Word.Application") 'создаем объект Word, чтобы можно было работать с его методами и свойствами
            With app
                .Visible = True 'запускаем приложение Word
                .Documents.Open strPathWord 'открываем документ (по пути в переменной strPathWord)
            End With
            Set app = Nothing 'уничтожаем переменную
        Else 'если пользователь выбрал Да - то есть согласился перезаписать документ
            GoTo nn 'переходим по метке nn
        End If
    Else 'если не нашлось документа по заданому в strPathWord полному пути
nn:
        Set app = New Word.Application 'делаем ссылку на объект Word для создания нового документа
        app.Visible = True 'запускаем приложение Word
        app.Documents.Add strPathDot 'присоединяем к объекту Word шаблон по заданому пути
        With app.ActiveDocument 'делаем ссылку на активный документ - в данном случае тот что формируется
            'находим закладку по имени в заменяем ее на текст из поля формы
            .Bookmarks.Item("ДатаДоговора").Range.Text = Nz(ДатаДоговора, "")
        .Bookmarks.Item("НомерПриложения").Range.Text = Nz(НомерПриложения, "")
            .Bookmarks.Item("Дата").Range.Text = Nz(ДатаДоговора, "")
            .Bookmarks.Item("НазваниеЖурнала").Range.Text = Nz(Название, "")
            .Bookmarks.Item("НазваниеЖурналаПриложение").Range.Text = Nz(Название, "")
            .Bookmarks.Item("ПорядокРасчета").Range.Text = Nz(ПорядокРасчетов, "")
            '.Bookmarks.Item("НомерДоговора").Range.Text = Nz(НомерДоговора, "")
            .Bookmarks.Item("ДоговорНомер").Range.Text = Nz(НомерДоговора, "")
            .Bookmarks.Item("Итого").Range.Text = Nz(Итогo, "")
            .Bookmarks.Item("Итого1").Range.Text = Nz(Итогo, "")
            .Bookmarks.Item("СуммаПр").Range.Text = Nz(Поле69, "")
            .Bookmarks.Item("СуммаПроп").Range.Text = Nz(Поле69, "")
            ' заполнить таблицу
            Call funOutputTableWordQuery(strPathDot, strPathWord)
                        
            'Чистим незаполненные закладки
            With .Bookmarks
                For i = .Count To 1 Step -1
                    'если имя Bookmark совпадает с его содержимым
                    If .Item(i).Name = .Item(i).Range.Text Then
                        'Удаляем содержимое (вместе с ним удаляется и сама Bookmark)
                        .Item(i).Range.Text = ""
                    End If
                Next i
            End With
 
            .SaveAs strPathWord 'сохраняем созданный документ по заданному пути strPathWord
        End With
        Set app = Nothing 'уничтожаем переменную
    End If
    funOutputWord = True 'ставим флаг успешного выполнения функции
    
Exit_:
    Exit Function
Err_:
    funOutputWord = False
    Err.Clear
    app.Quit
    Resume Exit_
End Function
 
 
Function TextDog(strPathDot As String, strPathWord As String) As Boolean
On Error GoTo Err_
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long, j As Long, NumStr As Long
 Dim CountRec As Long
 
Set dbs = CurrentDb()
 
           Set rst = dbs.OpenRecordset("ЗапросДог", dbOpenSnapshot)
           'Set rst = CurrentDb.OpenRecordset("QveryWord", dbOpenSnapshot)  'открываем запрос на чтение
            If rst.RecordCount > 0 Then 'если в запросе есть хоть одна строка
        With app.ActiveWindow.Selection 'ставим фокус на текущее окно
             
                For i = 0 To rst.Fields.Count - 1 'создаем цикл перебора столбцов запроса
                    If TrueBookmark(rst.Fields(i).Name, .Document) Then
                        .GoTo What:=wdGoToBookmark, Name:=rst.Fields(i).Name  'Перейти на закладку
                        Call SelectionText(app.ActiveWindow.Selection, Nz(rst.Fields(i), ""), 2, False) 'Вставить текст
                    End If
                Next i
               rst.Close 'закрываем рекордсет - при этом автоматически уничтожается и перенменная rst
                
            'Чистим незаполненные закладки
            With .Bookmarks
                For i = .Count To 1 Step -1
                    'если имя Bookmark совпадает с его содержимым
                    If .Item(i).Name = .Item(i).Range.Text Then
                        'Удаляем содержимое (вместе с ним удаляется и сама Bookmark)
                        .Item(i).Range.Text = ""
                    End If
                Next i
            End With
    
            app.ActiveDocument.SaveAs strPathWord 'сохраняем созданный документ по заданному пути strPathWord
        End With
        Set app = Nothing
    End If
    
    TextDog = True 'ставим флаг успешного выполнения функции
    
Exit_:
    Exit Function
Err_:
    TextDog = False
    Err.Clear
    app.Quit
    Resume Exit_
End Function
 
 
 
'функция выгрузки в Word значений полей запроса через закладки в шаблоне
Function funOutputWordQuery(strPathDot As String, strPathWord As String) As Boolean
On Error GoTo Err_
 
 
 
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long, j As Long, NumStr As Long
 Dim CountRec As Long
Set dbs = CurrentDb()
 Dim i As Long
Dim DlgUser As Integer
 
    'проверяем наличие софрмированного ранее документа
    If Dir(strPathWord) <> "" Then 'если нашелся документ по заданому в strPathWord полному пути (вместе с именем)
        DlgUser = MsgBox("Документ с таким именем ранее уже был создан. Заменить его?", vbYesNo)
        If DlgUser = vbNo Then 'если пользователь выбрал Нет - то открываем прежний вариант документа
            Set app = CreateObject("Word.Application") 'создаем объект Word, чтобы можно было работать с его методами и свойствами
            With app
                .Visible = True 'запускаем приложение Word
                .Documents.Open strPathWord 'открываем документ (по пути в переменной strPathWord)
            End With
            Set app = Nothing 'уничтожаем переменную
        Else 'если пользователь выбрал Да - то есть согласился перезаписать документ
            GoTo nn 'переходим по метке nn
        End If
    Else 'если не нашлось документа по заданому в strPathWord полному пути
nn:
        Set app = New Word.Application 'делаем ссылку на объект Word для создания нового документа
        app.Visible = True 'запускаем приложение Word
        app.Documents.Add strPathDot 'присоединяем к объекту Word шаблон по заданому пути
        With app.ActiveWindow.Selection 'делаем ссылку на активный документ - в данном случае тот что формируется
           Set rst = dbs.OpenRecordset("QveryWord", dbOpenSnapshot)
           'Set rst = CurrentDb.OpenRecordset("QveryWord", dbOpenSnapshot)  'открываем запрос на чтение
            If rst.RecordCount > 0 Then 'если в запросе есть хоть одна строка
                For i = 0 To rst.Fields.Count - 1 'создаем цикл перебора столбцов запроса
                    If TrueBookmark(rst.Fields(i).Name, .Document) Then
                        .GoTo What:=wdGoToBookmark, Name:=rst.Fields(i).Name  'Перейти на закладку
                        Call SelectionText(app.ActiveWindow.Selection, Nz(rst.Fields(i), ""), 2, False) 'Вставить текст
                    End If
                Next i
               rst.Close 'закрываем рекордсет - при этом автоматически уничтожается и перенменная rst
            End If
            'если в шаблоне нужно заполнить таблицу - запускаем соответсвующую функцию
            'если заполнять таблицу не нужно - убираем эту строку
           ' Call funOutputTableWordQuery(strPathDot, strPathWord)
    
            'Чистим незаполненные закладки
            With .Bookmarks
                For i = .Count To 1 Step -1
                    'если имя Bookmark совпадает с его содержимым
                    If .Item(i).Name = .Item(i).Range.Text Then
                        'Удаляем содержимое (вместе с ним удаляется и сама Bookmark)
                        .Item(i).Range.Text = ""
                    End If
                Next i
            End With
    
            app.ActiveDocument.SaveAs strPathWord 'сохраняем созданный документ по заданному пути strPathWord
        End With
        Set app = Nothing
    End If
    
    funOutputWordQuery = True 'ставим флаг успешного выполнения функции
    
Exit_:
    Exit Function
Err_:
    funOutputWordQuery = False
    Err.Clear
    app.Quit
    Resume Exit_
End Function
 
Private Sub butExit_Click()
    DoCmd.Close 'закрываем форму
End Sub
 
Private Sub butWord_Click()
    'запускаем функцию выгрузки в Word из полей формы
    Call funOutputWord(strPathDot, strPathWord)
End Sub
 
Private Sub butWordQuery_Click()
    'запускаем функцию выгрузки в Word из запроса
    Call funOutputWordQuery(strPathDot, strPathWord)
End Sub
 
'функция выгрузки в Word из запроса в таблицу
Function funOutputTableWordQuery(strPathDot As String, strPathWord As String) As Boolean
On Error GoTo Err_
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long, j As Long, NumStr As Long
 Dim CountRec As Long
 Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("Запрос2", dbOpenSnapshot) 'открываем запрос для перебора столбцов
CountRec = rst.RecordCount 'определяем число строк в запросе
     With app.ActiveWindow.Selection 'ставим фокус на текущее окно
           If CountRec > 0 Then 'смотрим, чтоб не пустой запрос
            rst.MoveLast 'переходим в конец набора строк - тем самым они гарантированно загружаются в переменную rstTable
            rst.MoveFirst 'возращаемся в начало набора строк
            If TrueBookmark("NZ", .Document) Then 'если есть закладка
                .GoTo What:=wdGoToBookmark, Name:="NZ" 'Перейти на закладку ZT - начало втыкания данных в таблицу
            End If
            'запоминаем номер строки таблицы где стоит начальная закладка
            j = .Information(wdEndOfRangeRowNumber)
            If CountRec > 1 Then
                'Вставим необходимое количество строк
                .InsertRowsBelow CountRec - 1
            End If
            'Заполняем таблицу данными из запроса
             NumStr = 1
            Do While Not rst.EOF 'Запускаем цикл перебора столбцов запроса
                For i = 0 To rst.Fields.Count - 1
                'MsgBox (rst.Fields(i).Name)
                    If rst.Fields(i).Name = "НомерСтроки" Then 'если в запросе будет столбец с именем NumStr - то вместо него в ячейку таблицы встанет порядковый номер записи
                        .Tables(1).Cell(j, i + 1).Range = NumStr
                    Else
                        'Заполняем таблицу по координатам: номер столбца, номер строки
                        .Tables(1).Cell(j, i + 1).Range = Nz(rst.Fields(i), "")
                    End If
                Next i
                rst.MoveNext 'переходим на следующую запись
                NumStr = NumStr + 1 'увеличиваем номер по порядку
                j = j + 1 'увеличиваем номер координаты ячейки (номер столбца)
            Loop
        End If
        rst.Close 'закрываем рекордсет - при этом автоматически уничтожается и перенменная rstTable
    End With
    funOutputTableWordQuery = True 'ставим флаг успешного выполнения функции
    
Exit_:
    Exit Function
Err_:
    funOutputTableWordQuery = False
    Err.Clear
    Resume Exit_
End Function