Word и mergefield

Option Compare Database
Option Explicit
'On Error GoTo Err_
Dim app As Object
 
 
Function funOutputWord140305(strPathDot As String, strPathWord As String) As Boolean
Debug.Print strPathDot
Debug.Print strPathWord
Dim DlgUser As Integer
    If Dir(strPathWord) <> "" Then
        DlgUser = MsgBox("Документ с таким именем ранее уже был создан. Заменить его?", vbYesNo, "admin")
        If DlgUser = vbNo Then
            Set app = CreateObject("Word.Application")
            With app
                .Visible = True
                .Documents.Open strPathWord
            End With
            Set app = Nothing
        Else
            GoTo nn
        End If
    Else
nn:
        Set app = CreateObject("Word.Application")
        app.Visible = True
        app.Documents.Add strPathDot
        
        With app.ActiveDocument
        
        mrepl "[НазваниеОрганизации]", Название_Организации
        mrepl "[КраткоеНазвание]", Краткое_Название
        mrepl "[ФИО]", ФИО
        mrepl "[ИОФ]", ИО_Фамилия
        mrepl "[Должность]", Должность
        mrepl "[ДействуетНаОсновании]", Действует_На_Основании
        mrepl "[АдресЮридический]", Адрес_юридический
        mrepl "[АдресПочтовый]", Адрес_почтовый
        mrepl "[ИНН]", ИНН
        mrepl "[КПП]", КПП
        mrepl "[ОГРН]", ОГРН
        mrepl "[РС]", Расчетный_счет
        mrepl "[Банк]", Банк
        mrepl "[НомерДоговора]", НомерДоговора
        mrepl "[ДолжностьРП]", ДолжностьРП
        
        .SaveAs Replace(strPathWord, """", "'")
        End With
        app.Activate
        Set app = Nothing
    End If
    funOutputWord140305 = True
Exit_:
    Exit Function
Err_:
    funOutputWord140305 = False
    Err.Clear
    app.Quit
    Resume Exit_
End Function
Sub mrepl(n1z, n2z)
app.Selection.Find.ClearFormatting
app.Selection.Find.Replacement.ClearFormatting
With app.Selection.Find
 
.Text = n1z
.Replacement.Text = "" & n2z
app.Selection.Find.Execute Replace:=2
''2-wdReplaceAll
 
End With
 
'app.Selection.Find.Execute Replace:=wdReplaceAll
End Sub

.Documents(wDoc).SelectContentControlsByTitle("CountDays").Item(1).Range.Text = rst!AddDays

.Bookmarks("закладка").Range.Text = "текст"

      If (iStatus = 10) Or (iStatus = 25) Then
         objWord.ActiveDocument.SelectContentControlsByTitle(sReportMergeField).Item(1).Range.Text = sHeadline1 & vbNewLine & sText2
      Else
         objWord.ActiveDocument.SelectContentControlsByTitle(sReportMergeField).Item(1).Range.Text = sHeadline2 & vbNewLine & sText2
      End If

' формируем имя временного файла, который будет мерджиться с документом
strMailmergeDataFilename = GetTempPath() & Year(Date) & "_" & Month(Date) & "_" & Day(Date) & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & Round(Rnd * 100) & ".txt"
 
' создаем временный CSV файл из запроса
DoCmd.TransferText acExportDelim, , gstrQUERYNAME, strMailmergeDataFilename, True
 
Set objWordDoc = GetObject(strTemplateFile, "Word.Document")
Set appWord = objWordDoc.Application
appWord.Visible = True
 
' создаем источник
objWordDoc.MailMerge.OpenDataSource _
    Name:=strMailmergeDataFilename, ConfirmConversions:=False, _
    ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
    PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
    WritePasswordTemplate:="", Revert:=False, Format:=0, _
    Connection:="", SQLStatement:="", SQLStatement1:=""
objWordDoc.MailMerge.Destination = wdSendToNewDocument
' мерджим данные
objWordDoc.MailMerge.Execute
Set objWordDocMerged = appWord.ActiveDocument
objWordDoc.MailMerge.DataSource.Close
objWordDoc.Save
objWordDoc.Close SaveChanges:=-1 '-1 = wdSaveChanges