Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWB"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' VBA Document      : ThisWB
' Author        : EducatedFool                     Date: 18.01.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public WithEvents app As Application
Attribute app.VB_VarHelpID = -1

Private Sub app_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next: Err.Clear
    If sh.Parent Is ThisWorkbook Then Exit Sub

    If Not SETT.GetBoolean("CheckBox_DisableDoubleClickOnHeader") Then
        If Target.Row = HEADER_ROW And Target.Cells.Count = 1 Then
            If Len(Trim(Target)) > 0 Then
                Cancel = True
                If Target <> Trim(Target) Then Target = Trim(Target)
                TriesCount& = 0: code$ = "{" & Trim(Target) & "}"
                Err.Clear
                Do
                    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                        .SetText code$
                        .PutInClipboard

                        .GetFromClipboard
                        res$ = .GetText
                        TriesCount& = TriesCount& + 1
                    End With
                Loop While res$ <> code$ And TriesCount& < 10

                If Err = 0 And res$ = code$ Then
                    Shell "Cmd.exe /c echo " & Chr(7), vbHide
                Else
                    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                        .SetText ""
                        .PutInClipboard
                    End With
                End If
            End If
        End If
    End If

    If Target.Cells.Count = 1 Then
        If HasLinkToObject(Target.Cells(1).text) Then Cancel = True: CtrlShiftT
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    DeleteProgramCommandBar
    Disable_HotKeys
End Sub

Private Sub Workbook_Open()
    On Error Resume Next: Dim FirstRun As Boolean
    FirstRun = SETT.IsFirstRun
    If FirstRun Then ShowFirstRunForm
    If SetupCancelled Then
        Application.DisplayAlerts = False
        If TrueDeveloper Then MsgBox "Setup Cancelled", vbInformation Else ThisWorkbook.Close False
        Application.DisplayAlerts = True
        Exit Sub
    End If
    Enable_AccessVBOM_Macro_DataConnections        ' disables notifications
    SaveSetting PROJECT_NAME$, "Setup", "AddinPath", ThisWorkbook.FullName
    If FirstRun Then If IsObject(F_Greeting) Then F_Greeting.Show
    CreateProgramCommandBar 0

    Enable_HotKeys
End Sub


Attribute VB_Name = "sh1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True


Attribute VB_Name = "shtr"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' Author        : Igor Vakhnenko                   Date: 08.01.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Const PREFIX$ = "MENU"

Function NewTranslateID() As String
    On Error Resume Next
    Dim ra As Range, coll As New Collection
    Set ra = shtr.Range(shtr.Range("a" & TRANSLATE_SHEET_FIRST_ROW), shtr.Range("A" & shtr.Rows.Count).End(xlUp))
    arr = ra.Value
    For i = LBound(arr) To UBound(arr)
        coll.Add arr(i, 1), CStr(arr(i, 1))
    Next i

    For i = 1 To 1000
        Err.Clear: id$ = PREFIX$ & "_" & Format(i, "0000")
        coll.Add id$, id$
        If Err = 0 Then NewTranslateID = id$: Exit Function
    Next
    MsgBox "Can't create ID$", vbExclamation, "Function NewTranslateID()"
End Function

Function ClipboardText()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        ClipboardText = .GetText
    End With
End Function

Sub SetClipboardText(ByVal txt$)
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText txt$
        .PutInClipboard
    End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next
    If Target.Column = 1 And Target.Cells.Count = 1 Then
        If Target <> "" Then Cancel = True: SetClipboardText "tt(""" & Target & """) "
    End If
End Sub


Attribute VB_Name = "mod_CommonFunctions"
'---------------------------------------------------------------------------------------
' Module        : mod_CommonFunctions
' Автор     : EducatedFool  (Игорь)                    Дата: 26.03.2012
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments
'---------------------------------------------------------------------------------------
Option Compare Text
Option Private Module

Function Chars(ByVal txt As String) As Variant
    On Error Resume Next: ReDim arr(0 To Len(txt) - 1)
    For i = LBound(arr) To UBound(arr): arr(i) = Mid(txt, i + 1, 1): Next i
    If Err Then Chars = Array() Else Chars = arr
End Function

Function SafeText(ByVal txt As String) As String
    For i = 1 To Len(txt)
        SafeText = SafeText & IIf(i = 1, "", "-") & AscW(Mid(txt, i, 1))
    Next i
End Function

Function RestoreText(ByVal txt As String) As String
    On Error Resume Next: arr = Split(txt, "-")
    For i = LBound(arr) To UBound(arr): arr(i) = ChrW(Val(arr(i))): Next i
    RestoreText = Join(arr, "")
End Function

Function TemplatesInfo(ByVal files As Collection)
    For Each item In files
        TemplatesInfo = TemplatesInfo & ";" & TemplateType(item)
    Next
    TemplatesInfo = Left(Mid(TemplatesInfo, 2), 100)
End Function

Function ColumnNameByColumnNumber(ByVal col As Long) As String
    resA1 = Application.ConvertFormula("=r1c" & col, xlR1C1, xlA1)
    ColumnNameByColumnNumber = col & " «" & Split(resA1, "$")(1) & "»"
End Function

Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As XlFindLookIn = xlValues, _
                 Optional LookAt As XlLookAt = xlWhole, _
                 Optional SearchOrder As XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False, _
                 Optional BeginsWith As String = vbNullString, _
                 Optional EndsWith As String = vbNullString, _
                 Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range

    Dim FoundCell As Range, FirstFound As Range, LastCell As Range, rngResultRange As Range
    Dim XLookAt As XlLookAt, Include As Boolean, CompMode As VbCompareMethod
    Dim Area As Range, MaxRow As Long, MaxCol As Long, BeginB As Boolean, EndB As Boolean

    CompMode = BeginEndCompare
    XLookAt = LookAt: If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then XLookAt = xlPart

   For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then MaxRow = .Cells(.Cells.Count).Row
            If .Cells(.Cells.Count).Column > MaxCol Then MaxCol = .Cells(.Cells.Count).Column
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
    Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
                                     LookIn:=LookIn, LookAt:=XLookAt, _
                                     SearchOrder:=SearchOrder, MatchCase:=MatchCase)

    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False    ' Loop forever. We'll "Exit Do" when necessary.
           Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.text, Len(BeginsWith)), _
                               BeginsWith, BeginEndCompare) = 0 Then Include = True
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.text, Len(EndsWith)), _
                               EndsWith, BeginEndCompare) = 0 Then Include = True
                End If
            End If
            If Include = True Then
                If rngResultRange Is Nothing Then
                    Set rngResultRange = FoundCell
                Else
                    Set rngResultRange = Application.Union(rngResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then Exit Do
            If (FoundCell.Address = FirstFound.Address) Then Exit Do
        Loop
    End If
    Set FindAll = rngResultRange
End Function


Attribute VB_Name = "mod_Main"
'---------------------------------------------------------------------------------------
' Module        : mod_Main                    Version:
' Author        : Igor Vakhnenko                   Date: 22.09.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text: Option Private Module        ': Option Explicit
Public Const PROJECT_NAME$ = "FillDocuments", PROJECT_YEAR& = 2012

Private Sub CreateCommandBar(): CreateProgramCommandBar 0: End Sub

Sub CreateProgramCommandBar(Optional ByVal RefreshOnly As Boolean = True)
    On Error Resume Next
    SaveDefaultSettings

    Dim AddinMenu As CommandBar, coll As Collection, i&, MainMacroButton As Object, NeedToSelectParser As Boolean
    Application.ScreenUpdating = False
    If Not RefreshOnly Then Run DeleteOldCommandBar
    Set AddinMenu = GetCommandBar(PROJECT_NAME, True Or RefreshOnly)

    ' menu begin
    Set MainMacroButton = Add_Control(AddinMenu, ct_BUTTON, 593, "CreateAllDocuments", tt("MENU_MainButton"), msoButtonIconAndCaption, True)

    If SETT.GetBoolean("CheckBox_ShowAdditionalMenu") Then
        Set ExtendedMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", "  " & tt("MENU_Extra"))
        Add_Control ExtendedMenu, ct_BUTTON, 385, "UpdateUDFs", "Восстановить формулы", msoButtonIconAndCaption, True        ' 202
        Add_Control ExtendedMenu, ct_BUTTON, 142, "CtrlShiftT", "Вставить ссылку на таблицу... (Ctrl + Shift + T)", msoButtonIconAndCaption, True
        Add_Control ExtendedMenu, ct_BUTTON, 218, "CtrlShiftI", "Вставить ссылку на изображение... (Ctrl + Shift + I)", msoButtonIconAndCaption, False        ' 508
        Add_Control ExtendedMenu, ct_BUTTON, 0, "AddImagesFilenamesValidationList_IntoSelectedRange", _
                    "Вставить список имён файлов картинок в выделенный диапазон, в виде выпадающего списка", msoButtonIconAndCaption, False        ' 508
        Add_Control ExtendedMenu, ct_BUTTON, 0, "AddAbsentFieldCodes", "Импортировать коды полей из шаблонов в заголовок таблицы ...", msoButtonIconAndCaption, True
        Add_Control ExtendedMenu, ct_BUTTON, 0, "ShowUsageExample", tt("ShowUsageExample"), msoButtonIconAndCaption, True

    End If

    '    If Not SETT.GetBoolean("HideSettingsButton") Then Add_Control AddinMenu, ct_BUTTON, 548, "ShowSettingsPage", "Настройки", msoButtonIconAndCaption, True
    '    If Not SETT.GetBoolean("HideAboutButton") Then Add_Control AddinMenu, ct_BUTTON, 487, "ShowMainForm", "О программе ...", msoButtonIconAndCaption, True

    AddSettingsSwitcher AddinMenu, ct_DROPDOWN, , "CreateAllDocuments", MainMacroButton
    ' menu end
    Add3Buttons AddinMenu

    If Not RefreshOnly Then
        RunWithDelay "ActivateAddinsTab"
        AddUpdateButton AddinMenu
        RunWithDelay "ActivateAddinsTab"
    End If

    If Developer Then
        Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
        'Add_Control AddinMenu, ct_BUTTON, , "ShowFirstRunForm", "Show FirstRun Form", msoButtonIconAndCaption, True
        Add_Control AddinMenu, ct_BUTTON, , "ToggleIsAddin", "Show/Hide TR Sheet", msoButtonIconAndCaption, True
    End If

    Set ThisWorkbook.app = Application
    Application.ScreenUpdating = True
End Sub

Sub SaveDefaultSettings()
    On Error Resume Next
    With SETT
        .LoadAllSettings

        .AddDefaultValue "CheckBox_InsertIntoFields", False
        .AddDefaultValue "CheckBox_TemplatesForm_SortByName", True
        .AddDefaultValue "MultiPage_Mode", 0        ' режим «обычная (горизонтальная) таблица»
        .AddDefaultValue "CheckBox_ReplaceExistingFieldCodesOnly", True    'False

        .AddDefaultValue "TextBox_CombineXLS_filename", "Сводный файл.xls", , True
        .AddDefaultValue "TextBox_SendInterval_Min", 0
        .AddDefaultValue "TextBox_SendInterval_Max", 0
        .AddDefaultValue "TextBox_HyperlinkText", "открыть файл", , True

        .AddDefaultValue "ComboBox_FirstRow", 1
        .AddDefaultValue "ComboBox_BaseColumn", 2, True
        .AddDefaultValue "ComboBox_TemplatesFilter_Column", 5, True
        .AddDefaultValue "ComboBox_LineFeed", Chr(11), , True
        .AddDefaultValue "TextBox_OutputMask", "{%str%} - {%filename%}.{%ext%}", , True

        .AddDefaultValue "ComboBox_FirstColumn", 1, True
        .AddDefaultValue "ComboBox_BaseRow", 2
        .AddDefaultValue "CheckBox_UseAllColumns", True

        .AddDefaultValue "TextBox_AttachCreatedFilesMask", "*", , True
        .AddDefaultValue "TextBox_AttachStaticFilesMask", "*", , True

        .AddDefaultValue "CheckBox_ShowFolderWhenDone", True
        .AddDefaultValue "CheckBox_TemplatesFilter_Enabled", False
        .AddDefaultValue "ComboBox_SendMark_Column", 10, True
        .AddDefaultValue "ComboBox_SendTime_Column", 11, True
        .AddDefaultValue "ComboBox_Multirow_GroupColumn", 1, True
    End With
End Sub

Sub SettingSetChanged()
    RunWithDelay "CreateProgramCommandBar", 0.5
End Sub

Sub UpdateAddinToolbar()
    RunWithDelay "CreateProgramCommandBar", 0.6
End Sub

Sub ToggleIsAddin()
    On Error Resume Next
    ThisWorkbook.IsAddin = Not ThisWorkbook.IsAddin
End Sub

Function GetFile_MainPicture() As String
    ' создаёт во временной папке файл, возвращает путь к созданному файлу
    On Error Resume Next:
    Dim F_TXT$, buf$, tmp_file$, i&, res$, ff&: Const BufLen& = 5000
    F_TXT$ = F_TXT$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000302020302020303030304030304050805050404050A070706080C0A0C0C0B0A0B0B0D0E12100D0E110E0B0B1016101113141515150C0F171816141812141514FFDB00430103040405040509050509140D0B0D1414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414FFC00011080030003003012200021101031101FFC400190000030101010000000000000000000000060708040905FFC40034100001030303020305060700000000000001020304050611000712213108132223324151611415717281911617245382A1A2FFC4001801000301010000000000000000000000000405060201FFC4002811000102060104000700000000000000000102110003040521314112132361323342517191E1FFDA000C03010002110311003F00EA9E82EEFDEAB06C0756CDC579512912539CC69339B4BDD3BFB3CF23FB6A6F455EA7E212BB5F37DEE1B9615AB02E155B4C59D4575516548925452D2653E472579B8C84A7D2A00E0A483A6BDA9B0BB55B774D4AE15914286FB5E8765CE6448712B1DCF9AF152867BF7F96B8F968D360AA31CAF1CDB2AC3CB618BC155092919F260D2E63C55F810D71FF007A67"
    F_TXT$ = F_TXT$ & "EDB6E7DB5BB96CA2BF6AD49352A71714CA95C14DADA713EF2168500A4A8641C11D8823A10740957A641AA4528A30A83C8EBC5119A5AE3FE8A5613FB13A9AAAF7F567C20EE755EE216FCC5D06EB88E34F53494F13554A14A8EEA42547A38414AB1D7AA8F5200D6886C98C020EA191E2777B6E4977FA6C0B1EB8EDBED52228A85C75A88DA5C758E63D8464641C2943D671D4829EA0056883C226F45D5B833EEFB5AE99AC57DFB70455355E8EC0655212F254783A84FA4389E1DD27AE7E9932B57E6CFDBFB3DF4CF52EAB79572519D5420725CBA83E7D0C803B8493C703A745918CEAE4F0CFB3436576BE152E514BD70CE51A856657425D94E60A867E2940C207E5CFC4EA36C5799D7A9F513909029D27A5079536CFE391AC11CC3CAEA34514996857CC564FA1C085D6F5C4776537C287B8D01EFBBEDDBB7CBB7AE57529050C48C7F473540F4CA4FA0A8F40918EEAD1CEE2DFD44DA8A741A95420546E59B2E4A6031163321D7E44929529011C8A50080859383D00FA68DF75F6F20EEC6DCDC1695470235522A990E1192D39DDB707D52B0950FCBA866BD7EDC53A2EDCDD1715424BD26DD151B72753D653C6257633652952940057379B0559513D720633AAA9EB32E52963603C2BA79626CE4CB27E22DFB865DCBE263712B0CADC8B1ADFB069DFDC"
    F_TXT$ = F_TXT$ & "94B352983F5CB6D27FEF4978551B937277426D46E5B8AA574C1B4E2B5528D1A5A1086DC92EE436F36CB684278200CE403EA03AE0EA8B776EE914C91C9EA0B956ABCF67CD764A5030CAD5D17C14E2B8B585F2F4A3A8C763AC7797856A7F888AD53EF1B96AEFDBD528713EEC9EDD2DFE42506CABD4B2A09E190A27033E950F97584956DBB5C513A55C6B1BAD253D2848012FB2FB38C64F382F98ACAB996FA444B5D1C87C8254A2E4B70DA1FCD44BD47A1DE9B9F7E1AFDB11A6B9FC3CFA9EA64D654CA5B5CF694DA94A3E6AD21C42393692067A2BEBAE8CECCEE635BB160C2AE18C69F514AD70EA54F5FBD0E63478BCD1FC14323E69524FC74ACA2DA966DA56052A9F46A84A71BA3151FB05216A506D414A121398C9E473ED082B249F4924EBCCDA0AAC7B0FC4655683104D6A877953CCF613350F026A11B01C29F33AFAD85249CF7F246AAAD76C976A9029E4A89480031660DB231F51C9C9CEA272B2B155ABEE2D201CE72E7ECF9E34303DC53DA86BC4BD9A2DFDDFB9E8EDE59837E52D35CA6908E41AACC0C1250803A9520214AC64AB2411AB9749FF00125B2351DE3A1505DA05523516E7A054533E04B96D95B441494B8DAC0EA12A041E80FBA07C73A710BE046C3BBFF9A9B7146AD427DDA63D2584BEF06D2952DA7127CB90D7AC10087123B8"
    F_TXT$ = F_TXT$ & "CE4A8FC74516952E814BABCA3582C496DD693210BAABE1D2975278A94942C9EA52A4754A46388F98D26697B45BB3B26E552834482EEE1FDFAA1514D618718A7330A5385425A1495ACF14A92968A4A41C92A38CF4D1150BC33EE55CB2FEDB73DE54FB590B6D2DAA25BF1CCB91C3912417DE012951CE094B67B0C76D0DD9F2F70183454F83B043FB86556378AD5B6555A7532D4F450E216BCA030CB4AF2D208E6B23A10127DDF89EF9D25769ABCEEFCEEFDA72EDB8A98F6ED96E2E649ACF985E52F932E30D454B984A54A5A5654BC27A0477C919725B5E11B6D6852D33AA3497AEFAA0214675CF2153D448EC7CB57B24FF008A0761F21A704488C408CDC78ACB71A3B69E2869A404A103E400E8068980A3FFD9"
    For i = 1 To Len(F_TXT$) / 2
        buf$ = buf$ & Chr(Val("&H" & Mid(F_TXT$, 2 * i - 1, 2)))
        If Len(buf$) > BufLen& Then res$ = res$ & buf$: buf$ = "": DoEvents
    Next: res$ = res$ & buf$
    tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
    ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff
    Put #ff, , res$
    Close #ff
    If FileLen(tmp_file$) = Len(F_TXT$) / 2 Then GetFile_MainPicture = tmp_file$ Else Debug.Print FileLen(tmp_file$), Len(F_TXT$) / 2
End Function

Sub ShowUsageExample()        ' запуск формы "ИНСТРУКЦИИ по работе с программой"
    On Error Resume Next: Dim UF As Object: Set UF = UserForms.Add("F_UsageExample")
    If Not UF Is Nothing Then UF.Show
End Sub

Sub FirstRunActions()
    On Error Resume Next
    SETT.SetText "TEMPLATE_FOLDER", tt("CONST_TEMPLATE_FOLDER"), "Setup"
    SETT.SetText "OUTPUT_FOLDER", tt("CONST_OUTPUT_FOLDER"), "Setup"
    x = TEMPLATES_FOLDER$
    x = OUTPUT_FOLDER$
End Sub


Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Module        : mod_Functions
' Author        : EducatedFool                     Date: 06.06.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit
Option Compare Text
Option Private Module

#If VBA7 Then        '  Office 2010-2013
    Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
            (ByVal hwnd As LongPtr, ByVal pszPath As String, ByVal psa As Any) As LongPtr
    Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else        '  Office 2003-2007
    Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                         (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
    Declare Function GetTickCount Lib "kernel32" () As Long
#End If

Sub CtrlShiftV()        ' PasteFormulasForSeparateLetters
    On Error Resume Next: Err.Clear
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        CopyFormulas .GetText
    End With
End Sub

Sub CopyFormulas(ByVal txt$)
    On Error Resume Next: Err.Clear
    Dim ra As Range, n&, nn&, k&, cell As Range, addr$

    Application.ScreenUpdating = False
    Set ra = Selection

    For Each cell In ra.Cells
        n = n + 1
        If n = 1 Then
            addr$ = cell.Address(1, 1, xlA1)
            cell.Value = txt
            cell.Font.Color = vbWhite
            cell.Font.Size = 1
        Else
            If cell.Address = cell.MergeArea.Cells(1).Address Then
                k = k + 1: cell.NumberFormat = "General"
                cell.Formula = "=MID(" & addr & "," & k & ",1)"
            End If
        End If
    Next cell
    If Err = 0 Then Shell "Cmd.exe /c echo " & Chr(7), vbHide
    Application.ScreenUpdating = True
End Sub

Sub Enable_HotKeys()
    ' назначает комбинации клавиш, если соответствующие опция включены в настройках программы
    On Error Resume Next
    With Application
        If SETT.GetBoolean("CheckBox_PasteFormulasForSeparateLetters") Then .OnKey "^+v", "CtrlShiftV" Else .OnKey "^+v"
        If SETT.GetBoolean("CheckBox_InsertTableLinks") Then .OnKey "^+t", "CtrlShiftT" Else .OnKey "^+t"
        If SETT.GetBoolean("CheckBox_InsertImageLinks") Then .OnKey "^+i", "CtrlShiftI" Else .OnKey "^+i"
    End With
End Sub

Sub Disable_HotKeys()
    On Error Resume Next: Err.Clear
    Application.OnKey "^+v"
End Sub

Function SpecialCells_TypeConstants(ByRef ra As Range) As Range
    ' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
    On Error Resume Next: Dim en&: en& = Err.Number
    If ra.Worksheet.ProtectContents Then        ' если лист защищён
        Dim cell As Range
        ' перебираем все ячейки в диапазоне
        For Each cell In Intersect(ra, ra.Worksheet.UsedRange).Cells
            If Trim(cell.Value) <> "" Then        ' если ячейка непустая
                ' то добавляем её в результат
                If SpecialCells_TypeConstants Is Nothing Then
                    Set SpecialCells_TypeConstants = cell
                Else
                    Set SpecialCells_TypeConstants = Union(SpecialCells_TypeConstants, cell)
                End If
            End If
        Next cell

    Else        ' если защита листа не установлена - используем штатные средства Excel
        Set SpecialCells_TypeConstants = ra.SpecialCells(xlCellTypeConstants)
    End If
    If en& = 0 Then Err.Clear
End Function

Function SpecialCells_VisibleRows(ByRef ra As Range) As Range
    On Error Resume Next: Dim en&: en& = Err.Number
    If ra.Worksheet.ProtectContents Then
        Dim ro As Range
        For Each ro In Intersect(ra, ra.Worksheet.UsedRange.EntireRow).Rows
            If ro.EntireRow.Hidden = False Then
                If SpecialCells_VisibleRows Is Nothing Then
                    Set SpecialCells_VisibleRows = ro
                Else
                    Set SpecialCells_VisibleRows = Union(SpecialCells_VisibleRows, ro)
                End If
            End If
        Next ro
    Else
        Set SpecialCells_VisibleRows = ra.SpecialCells(xlCellTypeVisible)
    End If
    If en& = 0 Then Err.Clear
End Function

Function RenderString(ByVal txt$, ByRef options As Dictionary) As String
    On Error Resume Next: Dim arr, i&: arr = options.Keys
    For i = LBound(arr) To UBound(arr)
        txt$ = Replace(txt$, arr(i), options(arr(i)))
    Next i
    RenderString = txt$
End Function

Function CreatePathForFile(ByVal OldFilename$, ByRef options As Dictionary) As String
    On Error Resume Next: Err.Clear
    Dim Mask$, ShortOldFilename$, subfolder$, filename$, pcc&, NewFolderPath$, NewFilename$

    Mask$ = SETT.GetText("TextBox_OutputMask")        ' f.e., {str} - {filename}.{ext}

    ShortOldFilename$ = Replace(OldFilename$, TEMPLATES_FOLDER$, "")

    subfolder$ = Left(ShortOldFilename$, InStrRev(ShortOldFilename$, "\") - 1)
    If Len(subfolder$) Then subfolder$ = subfolder$ & "\"

    filename$ = Dir(OldFilename$)
    filename$ = Left(filename$, InStrRev(filename$, ".") - 1)

    If filename$ Like "*{print=#*}*" Then
        pcc& = Val(Split(filename$, "{print=")(1))
        filename$ = Replace(filename$, "{print=" & pcc& & "}", "")
        options("{%pcc%}") = pcc&
    End If
    If filename$ Like "*{pdf}*" Then
        filename$ = Replace(filename$, "{pdf}", "")
        options("{%pdf%}") = 1
    End If

    options("{%filename%}") = RenderString(filename$, options)
    options("{%ext%}") = GetExtensionForNewFile(ShortOldFilename$)

    NewFilename$ = OUTPUT_FOLDER$ & subfolder$ & FWF.Replace_symbols(RenderString(Mask$, options), , True)

    ' создание папки для файла
    NewFolderPath$ = Left(NewFilename$, InStrRev(NewFilename$, "\"))
    If Len(Dir(NewFolderPath$, vbDirectory)) = 0 Then        ' если папка отсутствует
        SHCreateDirectoryEx Application.hwnd, NewFolderPath$, ByVal 0&        ' создаём путь
    End If

    If Val(Application.Version) > 11 And (SETT.GetBoolean("CheckBox_PDF") Or (Val(options("{%pdf%}")) = 1)) Then        ' вывод в ПДФ
        If TemplateType(OldFilename$) <> "TXT" Then
            NewFilename$ = Left(NewFilename$, InStrRev(NewFilename$, ".") - 1) & ".pdf"
        End If
    End If

    CreatePathForFile = NewFilename$
End Function

Function GetExtensionForNewFile(ByVal filename$)
    On Error Resume Next: Err.Clear
    Select Case FWF.GetFileExtension(filename$)
        Case "XLT": GetExtensionForNewFile = "XLS"
        Case "XLTM": GetExtensionForNewFile = "XLSM"
        Case "XLTX": GetExtensionForNewFile = "XLSX"
        Case "DOT": GetExtensionForNewFile = "DOC"
        Case "DOTM": GetExtensionForNewFile = "DOCM"
        Case "DOTX": GetExtensionForNewFile = "DOCX"
        Case "DOCXML": GetExtensionForNewFile = "XML"

        Case Else: GetExtensionForNewFile = FWF.GetFileExtension(filename$)
    End Select
End Function

Function GetFileFormatForNewFile(ByVal filename$) As Long
    On Error Resume Next: Err.Clear
    Select Case FWF.GetFileExtension(filename$)
        Case "CSV": GetFileFormatForNewFile = xlCSV
        Case "XLS": GetFileFormatForNewFile = xlWorkbookNormal
        Case "XLSM": GetFileFormatForNewFile = 52        ' xlOpenXMLWorkbookMacroEnabled
        Case "XLSX": GetFileFormatForNewFile = 51        ' xlOpenXMLWorkbook
        Case "DOC": GetFileFormatForNewFile = 0        ' wdFormatDocument
        Case "DOCM": GetFileFormatForNewFile = 13        ' wdFormatXMLDocumentMacroEnabled
        Case "DOCX": GetFileFormatForNewFile = 12        ' wdFormatXMLDocument
        Case "XML": GetFileFormatForNewFile = 19        ' wdFormatFlatXML (XML)
            ' Case "XML": GetFileFormatForNewFile = 11        ' wdFormatXML (XML 2003)
    End Select
End Function


Function CollectionOfRowsBlocks(ByRef ra As Range) As Collection
    ' получает диапазон строк ra, ищет в столбце ComboBox_Multirow_GroupColumn уникальные значения,
    ' разбивает диапазон на блоки строк, по каждому из уникальных значений
    On Error Resume Next: Err.Clear
    Set CollectionOfRowsBlocks = New Collection
    Dim cell As Range, coll As New Collection, txt$, block As Range, col&, msg$, v

    If SETT.GetBoolean("CheckBox_Multirow_GroupRows") Then
        col& = SETT.GetNumber("ComboBox_Multirow_GroupColumn")
        If col& = 0 Then
            msg$ = "В настройках программы включен режим «MiltiRow» с опцией" & vbNewLine & _
                   "«Группировать строки по заданному столбцу»" & vbNewLine & vbNewLine & _
                   "А номер столбца, по которому надо группировать строки, — не указан." & vbNewLine & vbNewLine & _
                   "Измените настройки программы, и снова запустите формирование документов."
            MsgBox msg, vbExclamation, "Не задан столбец, по которому группировать строки"
            ShowSettingsPage
            F_Settings.MultiPage_Options.Value = 4
            F_Settings.ComboBox_Multirow_GroupColumn.SetFocus
            F_Settings.ComboBox_Multirow_GroupColumn.BackColor = vbRed
            Exit Function
        End If

        For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Columns(col&)).Cells
            txt$ = Trim(cell): If Len(txt$) Then coll.Add txt$, txt$
        Next cell

        If coll.Count = 0 Then
            msg$ = "В настройках программы включен режим «MiltiRow» с опцией" & vbNewLine & _
                   "«Группировать строки по заданному столбцу»" & vbNewLine & vbNewLine & _
                   "Указан номер столбца, по которому надо группировать строки: «" & col& & "»" & vbNewLine & vbNewLine & _
                   "В этом столбце, в выбранных строках, программа не нашла ни одной заполненной ячейки." & vbNewLine & _
                   "Измените настройки программы, и снова запустите формирование документов."
            MsgBox msg, vbExclamation, "Не задан столбец, по которому группировать строки"
            ShowSettingsPage
            F_Settings.MultiPage_Options.Value = 4
            F_Settings.ComboBox_Multirow_GroupColumn.SetFocus
            F_Settings.ComboBox_Multirow_GroupColumn.BackColor = vbRed
            Exit Function
        End If

        For Each v In coll
            Set block = Nothing
            For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Columns(col&)).Cells
                If Trim(cell) = v Then
                    If block Is Nothing Then Set block = cell Else Set block = Union(block, cell)
                End If
            Next cell
            If block Is Nothing Then
                MsgBox "Ошибка группировки строк в режиме Multirow", vbCritical, "Обратитесь к разработчику программы"
                Exit Function
            Else
                CollectionOfRowsBlocks.Add block.EntireRow
            End If
        Next v

    Else        ' возвращаем один блок - со всеми строками
        CollectionOfRowsBlocks.Add ra
    End If
End Function


Function CreateAndFill_XLS(ByVal TemplateFilename$, ByVal NewFilename$, _
                           ByRef AllOptions As Dictionary, Optional ByRef pi As ProgressIndicator) As Boolean

    On Error Resume Next: Err.Clear
    Dim WB As Workbook, sh As Worksheet, nam As Name, ra As Range, calc As XlCalculation, i&, txt_Line2$, options As Dictionary
    pi.Line3 = "Файл: " & Dir(TemplateFilename$, vbNormal)

    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    If TemplateType(TemplateFilename$) Like "*template*" Then
        pi.line2 = "Создание документа Excel по шаблону ..."
        Set WB = Application.Workbooks.Add(TemplateFilename$)
    Else
        pi.line2 = "Открытие исходного документа Excel ..."
        Set WB = Application.Workbooks.Open(TemplateFilename$, False, True)
    End If

    '  Main_PI.Log "Документ создан? " & Not (WB Is Nothing)

    If SETT.GetBoolean("CheckBox_ReplaceExistingFieldCodesOnly") Then
        Set options = GetTemplateOptions(AllOptions, LoadFieldCodes_ExcelWorkbook(WB))
    Else
        Set options = AllOptions
    End If


    If SETT.GetBoolean("CheckBox_MultiRow") Then        ' размножение специальных строк в шаблоне
        Dim rc&: rc = Val(AllOptions("{%rc%}"))
        If rc& = 0 Then Main_PI.Log vbTab & "Ошибка при подготовке документа Excel: rc& = 0": Exit Function
        pi.line2 = "Добавление строк (" & rc& & " шт.) - режим MULTIROW ..."

        For Each nam In WB.Names
            If nam.Name Like "MultiRow*" Then
                Set ra = Nothing: Set ra = nam.RefersToRange.EntireRow
                'Debug.Print  nam.Name, ra.Address
                If Not ra Is Nothing Then
                    If ra.Rows.Count <= 100 Then
                        For i = 1 To rc&
                            ra.Offset(i * ra.Rows.Count).Insert Shift:=xlDown
                            ra.Copy ra.Offset(i * ra.Rows.Count)
                            ra.Offset(i * ra.Rows.Count).Replace "#}", "#" & i & "}", xlPart
                            ra.Offset(i * ra.Rows.Count).Replace "{%index%}", i, xlPart
                        Next i
                        ra.EntireRow.Delete
                    End If
                End If
            End If
        Next
    End If

    txt_Line2$ = "Подстановка значений в созданный по шаблону документ ..."
    pi.line2 = txt_Line2$

    Dim RIC As Boolean, arr, key$, txt$, File_Format
    arr = options.Keys

    RIC = SETT.GetBoolean("CheckBox_ReplaceInColon")

    For i = LBound(arr) To UBound(arr)
        key$ = arr(i)
        txt$ = options(arr(i))

        For Each sh In WB.Worksheets
            If HasLinkToObject(txt$, key$) Then
                InsertObjectIntoXLS sh, txt$, key$, pi
                Err.Clear
            Else
                sh.UsedRange.Replace key$, txt$, xlPart, , False

                If RIC Then
                    With sh.PageSetup
                        .LeftFooter = Replace(.LeftFooter, key$, txt$, , , vbTextCompare)
                        .LeftHeader = Replace(.LeftHeader, key$, txt$, , , vbTextCompare)
                        .CenterFooter = Replace(.CenterFooter, key$, txt$, , , vbTextCompare)
                        .CenterHeader = Replace(.CenterHeader, key$, txt$, , , vbTextCompare)
                        .RightFooter = Replace(.RightFooter, key$, txt$, , , vbTextCompare)
                        .RightHeader = Replace(.RightHeader, key$, txt$, , , vbTextCompare)
                    End With
                End If
            End If
        Next sh

        If i Mod IIf(RIC, 5, 30) = 0 Then
            pi.line2 = txt_Line2$ & "  (выполнено " & Format(i / UBound(arr), "0%") & ")"
        End If
        DoEvents
    Next i

    pi.line2 = "Вычисление (пересчёт) формул ..."
    For Each sh In WB.Worksheets
        sh.Calculate
        If SETT.GetBoolean("CheckBox_FormulasToValues") Then sh.UsedRange.Value = sh.UsedRange.Value
    Next sh

    Application.Run "'" & WB.Name & "'!FillDone"

    pi.line2 = "Сохранение заполненного документа ..."
    pi.Line3 = "Новое имя файла: " & Split(NewFilename$, "\")(UBound(Split(NewFilename$, "\")))
    Main_PI.Log vbTab & "Сохранение созданного файла: " & Replace(NewFilename$, OUTPUT_FOLDER$, "...\")
    pi.FP.Repaint

    If Val(Application.Version) > 11 And (SETT.GetBoolean("CheckBox_PDF") Or (Val(AllOptions("{%pdf%}")) = 1)) Then        ' вывод в ПДФ
        WB.ExportAsFixedFormat 0, NewFilename$        ' xlTypePDF = 0
    Else        ' обычное сохранение файла Excel
        File_Format = GetFileFormatForNewFile(NewFilename$)
        If Len(File_Format) Then
            WB.SaveAs NewFilename$, Val(File_Format)
        Else
            WB.SaveAs NewFilename$
        End If
    End If
    If SETT.GetBoolean("CheckBox_ImmediatePrintOut") Then WB.PrintOut , , PrintCopiesCount(AllOptions)
    WB.Close False

    CreateAndFill_XLS = Err = 0

    Application.Calculation = calc
    Application.DisplayAlerts = True
End Function




Function PrintCopiesCount(ByRef options As Dictionary) As Long
    On Error Resume Next
    Dim en&, PrintCopiesField$, CopiesCount&, pcc As Variant
    en& = Err.Number
    PrintCopiesCount = 1

    PrintCopiesField$ = options("{%PrintCopiesCount%}")
    If PrintCopiesField$ Like "{*?}" Then
        CopiesCount& = Fix(Val(options(PrintCopiesField$)))
    Else
        CopiesCount& = Fix(Val(PrintCopiesField$))
    End If
    If CopiesCount& > 0 Then PrintCopiesCount = CopiesCount&

    pcc = options("{%pcc%}")
    If pcc <> "" Then PrintCopiesCount = Val(pcc)

    If en& = 0 Then Err.Clear        ' Debug.Print "PrintCopiesCount = " & PrintCopiesCount
End Function

Function CreateAndFill_DOC(ByVal TemplateFilename$, ByVal NewFilename$, _
                           ByRef AllOptions As Dictionary, Optional ByRef pi As ProgressIndicator) As Boolean
    On Error Resume Next: Err.Clear
    Dim doc As Object, ecount As Long, bm As Object, myStoryRange As Object, i&, oFirstCellRange As Object, bmText$, options As Dictionary
    pi.Line3 = "Шаблон: " & Dir(TemplateFilename$, vbNormal)

    If TemplateType(TemplateFilename$) Like "*template*" Then
        pi.line2 = "Создание документа Word по шаблону ..."
        Set doc = WA.Documents.Add(TemplateFilename$)
    Else
        pi.line2 = "Открытие исходного документа Word ..."
        Set doc = WA.Documents.Open(TemplateFilename$, , False, False)
    End If

    If SETT.GetBoolean("CheckBox_ReplaceExistingFieldCodesOnly") Then
        Set options = GetTemplateOptions(AllOptions, LoadFieldCodes_WordDocument(doc))
    Else
        Set options = AllOptions
    End If

    '  Main_PI.Log "Документ создан? " & Not (doc Is Nothing)
    doc.ActiveWindow.View.ShowFieldCodes = True        ' отображаем поля

    Dim TimeStamp As Double, ProcessTime1$, ProcessTime2$, Mcol&, MColumnTxt$, MColValue$: TimeStamp = Timer

    If SETT.GetBoolean("CheckBox_MultiRow") Then        ' размножение специальных строк в шаблоне

        TimeStamp = Timer: Dim rc&: rc = Val(AllOptions("{%rc%}"))
        If rc& = 0 Then Main_PI.Log vbTab & "Ошибка при подготовке документа Word: rc& = 0": Exit Function

        '  Dim bm As Bookmark, ra As word.Range, oFirstCellRange As word.Range
        pi.line2 = "Размножение строк (с закладками MULTIROW) ..."
        For Each bm In doc.Bookmarks
            If bm.Name Like "MultiRow*" Then

                Mcol& = 0
                If bm.Name Like "MultiRow*_col?*" Then        ' закладка с указанием номера столбца, - на основании которого размножать строки
                    MColumnTxt$ = UCase(Split(bm.Name, "_col")(1))
                    If Val(MColumnTxt$) Then
                        Mcol& = Val(MColumnTxt$)
                    Else
                        If (MColumnTxt$ Like "[A-Z]") Or (MColumnTxt$ Like "[A-Z][A-Z]") Then
                            Mcol& = ThisWorkbook.Worksheets(1).Range(MColumnTxt$ & "1").Column
                        End If
                    End If
                End If
                If Mcol& > 0 Then If rc& <> SourceRows.Rows.Count Then Debug.Print "rc&<>SourceRows.Rows.Count", rc&, SourceRows.Rows.Count

                If bm.Range.Information(12) Then        'Закладка в таблице
                    For i = 1 To rc&
                        pi.Line3 = "Метка «" & bm.Name & "», подготавливается строка " & i & " из " & rc&

                        MColValue$ = "": MColValue$ = Trim(SourceRows.Cells(i, Mcol&).text)        ' для Multirow по заданному столбцу
                        If (Mcol& = 0) Or (Len(MColValue$) > 0) Then
                            With bm.Range
                                Set oFirstCellRange = .Cells(1).Range
                                oFirstCellRange.Collapse 1        'wdCollapseStart
                                .Copy
                                'Вставка строки из закладки над закладкой
                                oFirstCellRange.PasteAndFormat 16        'wdFormatOriginalFormatting
                                WordReplacements .Tables(1).Rows(.Rows(1).Index).Range, "#}", "#" & i & "}"
                                WordReplacements .Tables(1).Rows(.Rows(1).Index).Range, "{%index%}", i
                                If SETT.GetBoolean("CheckBox_Multirow_InsertPageBreaks") Then
                                    If i > IIf(SETT.GetBoolean("CheckBox_Multirow_InsertPageBreaksAfterSecondRow"), 1, 0) Then
                                        oFirstCellRange.InsertBreak Type:=7        ' wdPageBreak = 7
                                    End If
                                End If
                            End With
                            DoEvents
                        End If
                    Next
                    bm.Range.Rows(1).Delete
                Else
                    bmText$ = bm.Range.text
                    For i = rc& To 1 Step -1
                        pi.Line3 = "Метка «" & bm.Name & "», подготавливается строка " & rc - i + 1 & " из " & rc&

                        MColValue$ = "": MColValue$ = Trim(SourceRows.Cells(i, Mcol&).text)        ' для Multirow по заданному столбцу
                        If (Mcol& = 0) Or (Len(MColValue$) > 0) Then
                            With bm.Range
                                .InsertParagraphAfter
                                With .Paragraphs.First.Next
                                    .Range.InsertCrossReference ReferenceType:=2, ReferenceKind:=-1, _
                                                                ReferenceItem:=bm.Name, InsertAsHyperlink:=False, _
                                                                IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                                    .Range.Fields.Unlink
                                End With
                                WordReplacements .Paragraphs.First.Next.Range, "#}", "#" & i & "}"
                                WordReplacements .Paragraphs.First.Next.Range, "{%index%}", i
                            End With
                            DoEvents
                        End If
                    Next
                    bm.Range.Delete
                End If
                DoEvents
            End If
        Next
        ProcessTime1$ = Format(Timer - TimeStamp, "0.00") & " сек."
    End If

    pi.line2 = "Подстановка значений в созданный по шаблону документ..."
    pi.Line3 = "Шаблон: " & Dir(TemplateFilename$, vbNormal)

    Dim arr, FullReplace As Boolean, Replace_LF_with$, key$, txt$, File_Format As Long, lngJunk As Long, oShp As Object, rangeColl As Collection
    arr = options.Keys

    Replace_LF_with$ = Replace(SETT.GetText("ComboBox_LineFeed"), "del", "")
    FullReplace = SETT.GetBoolean("CheckBox_ReplaceInColon")

    TimeStamp = Timer
    For i = LBound(arr) To UBound(arr)
        key$ = arr(i)
        txt$ = options(arr(i))
        txt$ = Replace(txt$, Chr(10), Replace_LF_with$)        ' переносы строк
        Err.Clear

        pi.line2 = "Подстановка значений в созданный по шаблону документ... (" & i + 1 & " / " & UBound(arr) + 1 & ")"
        If HasLinkToObject(txt$, key$) Then
            InsertObjectIntoDOC doc, txt$, key$, pi
            Err.Clear
        Else
            If FullReplace Then
                ' новая версия замены

                lngJunk = doc.Sections(1).Headers(1).Range.StoryType    'Fix the skipped blank Header/Footer problem

                Set rangeColl = New Collection
                For Each myStoryRange In doc.StoryRanges
                    rangeColl.Add myStoryRange
                Next

                For Each myStoryRange In rangeColl          'For Each myStoryRange In doc.StoryRanges
                    Do
                        DoEvents
                        WordReplacements myStoryRange, key$, txt$

                        If SETT.GetBoolean("CheckBox_ReplaceInColonShapes") Then
                            DoEvents
                            Select Case myStoryRange.StoryType
                                Case 6, 7, 8, 9, 10, 11
                                    If myStoryRange.ShapeRange.Count > 0 Then
                                        Dim Line3$, shapeindex&
                                        shapeindex& = 0: Line3$ = "Замена текста в графических объектах (XXX / " & myStoryRange.ShapeRange.Count & ")"
                                        For Each oShp In myStoryRange.ShapeRange
                                            If oShp.TextFrame.HasText Then WordReplacements oShp.TextFrame.TextRange, key$, txt$
                                            shapeindex& = shapeindex& + 1: If shapeindex& Mod 10 = 0 Then pi.Line3 = Replace(Line3$, "XXX", shapeindex&)
                                        Next
                                        pi.Line3 = ""
                                    End If
                                Case Else
                                    'Do Nothing
                            End Select
                        End If

                        Set myStoryRange = myStoryRange.NextStoryRange    'Get next linked story (if any)
                    Loop Until myStoryRange Is Nothing

                    '    WordReplacements myStoryRange, key$, txt$
                    '    While Not (myStoryRange.NextStoryRange Is Nothing)
                    '        DoEvents
                    '        Set myStoryRange = myStoryRange.NextStoryRange
                    '        WordReplacements myStoryRange, key$, txt$
                    '    Wend
                Next myStoryRange
                Set rangeColl = Nothing

                ' выход из режима редактирования колонтитулов (иначе пустой колонтитул отображается)
                doc.ActiveWindow.ActivePane.View.SeekView = 9  ' wdSeekCurrentPageHeader
                doc.ActiveWindow.ActivePane.View.SeekView = 0    ' wdSeekMainDocument

            Else
                ' обычная быстрая замена
                'doc.Range.Find.Execute key$, False, , False, , , , , , txt$, 2
                WordReplacements doc.Range, key$, txt$
            End If
        End If


        If Err Then
            If (Err.Number = 4605) And SETT.GetBoolean("CheckBox_InsertIntoFields") Then
            Else
                ecount = ecount + 1
                pi.Parent.Log "ОШИБКА " & Err.Number & " при подстановке данных в поле " & key$ & ": " & Err.Description
            End If
        End If

    Next i

    If SETT.GetBoolean("CheckBox_InsertIntoFields") Then        ' подстановка в защищённый документ
        Dim ff As Object, k As Variant
        For Each ff In doc.Fields
            If ff.Result.text Like "*{*}*" Then
                txt$ = ff.Result.text
                For Each k In options.Keys
                    txt = Replace(txt, k, options(CStr(k)))
                Next
                ff.Result.text = txt$
            End If
        Next
    End If

    ProcessTime2$ = Format(Timer - TimeStamp, "0.00") & " сек."

    doc.ActiveWindow.View.ShowFieldCodes = False        ' скрываем поля


    pi.line2 = "Сохранение заполненного документа ..."
    pi.Line3 = "Новое имя файла: " & Split(NewFilename$, "\")(UBound(Split(NewFilename$, "\")))
…