Malicious Office (OLE) / .XLS — 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
'---------------------------------------------------------------------------------------
' Author: Igor Vakhnenko       Engine version: 4       Date: 07.10.2025
' ExcelVBA.ru     Professional application development for Microsoft Excel
'---------------------------------------------------------------------------------------
Option Explicit: Option Compare Text

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: Dim txt$: Err.Clear: If Target.Cells.Count > 1 Then Exit Sub
    If sh.Parent Is ThisWorkbook Then Exit Sub
    If Target.Row = HEADER_ROW Then
        If Not SETT.GetBoolean("CheckBox_DisableDoubleClickOnHeader") Then
            If Len(Trim(Target)) > 0 Then
                Cancel = True: txt$ = Trim(Target)
                SetClipboard "{" & txt$ & "}"
                Shell SETT.U("436D642E657865202F63206563686F2007"), vbHide
            End If
        End If
    End If
    If HasLinkToObject(Target.Cells(1).Text) Then Cancel = True: CtrlShiftT
End Sub

Private Sub app_SheetBeforeRightClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next: Dim ind&, txt$
    Application.CommandBars("Cell").Reset ' сброс меню к настрокам по умолчанию
    If (Target.Row = HEADER_ROW) And (Target.Cells.Count = 1) Then
        txt$ = "{" & Trim(Target.Value) & "}": If Len(txt$) = 2 Then Exit Sub
        With Application.CommandBars("Cell")
            ind& = 1: ind& = .FindControl(, 19).index + 1
            With .Controls.Add(msoControlButton, 19, , ind&, True)
                .Caption = .Caption & " код поля " & txt
                .OnAction = "RunMacroFromButton": .Tag = "CopyToClipboard///" & txt
            End With
        End With
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    RunMacro PROJECT_NAME$ & "_OnClose"
    AddinBeforeClose
End Sub

Private Sub Workbook_Open()
    On Error Resume Next
    Application.OnTime Now, TWN & "AddinStarted"
    RunMacro PROJECT_NAME$ & "_OnOpen"
End Sub

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       Engine version: 4       Date: 07.10.2025
' ExcelVBA.ru     Professional application development for Microsoft Excel
'---------------------------------------------------------------------------------------
Option Explicit: Option Compare Text

Const PREFIX$ = "MENU"

Function NewTranslateID() As String
    On Error Resume Next
    Dim ra As Range, coll As New Collection, arr, i&, ID$
    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 = "sh_const"
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 = "shf"
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 = "mod_CommonFunctions"
'---------------------------------------------------------------------------------------
' Author: Igor Vakhnenko       Engine version: 4       Date: 07.10.2025
' ExcelVBA.ru     Professional application development for Microsoft Excel
'---------------------------------------------------------------------------------------
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 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 = SearchRange.Worksheet.Parent.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"
'---------------------------------------------------------------------------------------
' Author: Igor Vakhnenko       Engine version: 4       Date: 07.10.2025
' ExcelVBA.ru     Professional application development for Microsoft Excel
'---------------------------------------------------------------------------------------
Option Explicit: Option Compare Text: Option Private Module
Public Const PROJECT_NAME$ = "FillDocuments", PROJECT_YEAR& = 2012, MANUAL_EXISTS = True, USAGE_EXAMPLE_EXISTS = True, MAX_MESSAGES_COUNT& = 100

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
    Dim ExtendedMenu, subMenuDD, InsertObjects, Manuals
    Application.ScreenUpdating = False
    Set AddinMenu = GetCommandBar(PROJECT_NAME, True Or RefreshOnly)

    Set MainMacroButton = Add_Control(AddinMenu, ct_BUTTON, 6970, "CreateAllDocuments", tt("MENU_MainButton"), msoButtonIconAndCaption, True)   ' 6238 old 593
    Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
    
    Set ExtendedMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", "  " & tt("MENU_Extra"))
    
    Set Manuals = Add_Control(ExtendedMenu, ct_POPUP, 0, "", tt("MENU_MANUALS"), , True)
        Add_Control Manuals, ct_BUTTON, 1954, "ShowManual", tt("MENU_FilenameMask"), msoButtonIconAndCaption, , "FilenameMask"
        Add_Control Manuals, ct_BUTTON, 1954, "ShowManual", tt("MENU_FieldCodes"), msoButtonIconAndCaption, , "templates/FieldCodes"
        Add_Control Manuals, ct_BUTTON, 1954, "ShowManual", tt("MENU_InsertQR"), msoButtonIconAndCaption, , "barcodes_and_images"
        Add_Control Manuals, ct_BUTTON, 1954, "ShowManual", tt("MENU_Mailing"), msoButtonIconAndCaption, , "mailing"
        Add_Control Manuals, ct_BUTTON, 1954, "ShowManual", tt("MENU_SettingsSwitcher"), msoButtonIconAndCaption, True, "/programmes/common/SettingSwitcher"
                
    CreateFormulaMenu ExtendedMenu
    Add_Control ExtendedMenu, ct_BUTTON, 5473, "UpdateUDFs", tt("MENU_RestoreFormulas") & " ...", msoButtonIconAndCaption ' 202
    
    Set InsertObjects = Add_Control(ExtendedMenu, ct_POPUP, 0, "", tt("MENU_InsertObjects"), , True)
        Add_Control InsertObjects, ct_BUTTON, 1954, "ShowManual", tt("MENU_InsertObjectsHelp"), msoButtonIconAndCaption, True, "insert"
        Add_Control InsertObjects, ct_BUTTON, 142, "CtrlShiftT", tt("Insert table link") & " ... (Ctrl + Shift + T)", msoButtonIconAndCaption, True
        Add_Control InsertObjects, ct_BUTTON, 218, "CtrlShiftI", tt("Insert image link") & " ... (Ctrl + Shift + I)", msoButtonIconAndCaption, False       ' 508
        Add_Control InsertObjects, ct_BUTTON, 0, "AddImagesFilenamesValidationList_IntoSelectedRange", tt("MENU_ImgDropdown"), msoButtonIconAndCaption, False                           ' 508
                
    Add_Control ExtendedMenu, ct_BUTTON, 0, "AddAbsentFieldCodes", tt("MENU_TemplateCodesToHeader"), msoButtonIconAndCaption, True
    Add_Control ExtendedMenu, ct_BUTTON, 0, "ShowUsageExample", tt("ShowUsageExample"), msoButtonIconAndCaption, True
    Add_Control ExtendedMenu, ct_BUTTON, 1954, "ShowManual", tt("manual"), msoButtonIconAndCaption, True, "/programmes/FillDocuments/manuals"


    AddSettingsSwitcher AddinMenu, ct_DROPDOWN, , "CreateAllDocuments", MainMacroButton
    ' menu end
    Add3Buttons AddinMenu
    If Not RefreshOnly Then RunWithDelay "ActivateAddinsTab"

    If Developer Then
        Set subMenuDD = Add_Control(AddinMenu, ct_POPUP, 0, "", "   ", , True)
        Add_Control subMenuDD, ct_BUTTON, 9378, "Admin_ToggleIsAddin", "Show/Hide TR Sheet", msoButtonIconAndCaption, True
        Add_Control subMenuDD, ct_BUTTON, , "Admin_ShowFirstRunForm", "Show FirstRun Form", msoButtonIconAndCaption
        Add_Control subMenuDD, ct_BUTTON, 4171, "Admin_CF_EditVL", "CF: Edit list", msoButtonIconAndCaption
        Add_Control subMenuDD, ct_BUTTON, 4356, "Admin_ClearASettings", "Clear Settings", msoButtonIconAndCaption
        Add_Control subMenuDD, ct_BUTTON, , "ShowFaceIDs", "Show FaceIDs", msoButtonIconAndCaption
        Add_Control subMenuDD, ct_BUTTON, 0, "Admin_ChangeLanguageFromMenu", "Change Language RU <-> EN", msoButtonIconAndCaption, True
        Add_Control subMenuDD, ct_BUTTON, , "ShowACPCorrectionFile", "Set ACP 1250", msoButtonIconAndCaption, True, 1250
        Add_Control subMenuDD, ct_BUTTON, , "ShowACPCorrectionFile", "Set ACP 1251", msoButtonIconAndCaption, , 1251
        Add_Control subMenuDD, ct_BUTTON, , "ShowACPCorrectionFile", "Set ACP 1252", msoButtonIconAndCaption, , 1252
    End If

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

Sub MigrationE3() ' переход на новую версию
    On Error Resume Next
    SETT.SetText "CheckBox_ShowFolderWhenDone", False
    SETT.Delete "CheckBox_CloseProgressBar"
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
        .AddDefaultValue "MultiPage_SendMode", 1        ' рассылка через Outlook по умолчанию

        .AddDefaultValue "TextBox_CombineXLS_filename", te("Сводный файл.xlsx"), , True
        .AddDefaultValue "TextBox_SendInterval_Min", 0
        .AddDefaultValue "TextBox_SendInterval_Max", 0
        .AddDefaultValue "TextBox_HyperlinkText", te("открыть файл"), , 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 "CheckBox_ShowPopupOnFinish", True
        .AddDefaultValue "ComboBox_ShowFilenamesInPopup", 10

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

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

Sub CreateFormulaMenu(ByRef parentMenu)
    On Error Resume Next
    Dim arr, coll As New Collection, i&, group, submenu, n&
    arr = shf.ListObjects("functions").DataBodyRange.Value
    For i = LBound(arr) To UBound(arr)
        coll.Add arr(i, 1), arr(i, 1)
    Next i
    For Each group In coll
        Set submenu = Add_Control(parentMenu, ct_POPUP, 0, "", tt("Useful formulas") & ":  " & group, , n& = 0): n& = n& + 1
        For i = LBound(arr) To UBound(arr)
            If arr(i, 1) = group Then
                Add_Control submenu, ct_BUTTON, 385, "ShowSheetFunction", arr(i, 2), msoButtonIconAndCaption, , arr(i, 2)
            End If
        Next i
    Next group
End Sub

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

Sub UpdateAddinToolbar()
    RunWithDelay "CreateProgramCommandBar", 0.6
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$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000504040504030505040506060506080E0908070708110C0D0A0E141115141311131316181F1B16171E1713131B251C1E2021232323151A26292622291F222322FFDB00430106060608070810090910221613162222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222FFC0001108001F006A03012200021101031101FFC4001B00000300030101000000000000000000000607080002040509FFC4003F10000103030302020704040F0000000000010203040506110012210731134108141522325161168191B1234671A125263342627273759495B2C1D1D3E2FFC400190100020301000000000000000000000000030402050601FFC40024110001040201040203000000000000000001000203110421120531415113B12271F1FFDA000C03010002110311003F00625C3E91B260D52642A5DBAD9546794D78B2A51C28A4919DA94FD3E7A07A8F5FEF69A5422BB4F8093E51E36E23EF593F96876145A4CFEAEC8837187453A6D41D8E5C69C29534B5AC842FEA02B191F23AD6FAB7E15A4ED328094072BB198F16AD292E28A4B8BE50DA4760129C1C8EFBB4B973BBDACF493E4B81772D034A86B33A8D56"
    F_TXT$ = F_TXT$ & "996253A65423C098F0693EB12DDAB30C12A5138DC8C7B84E381F4D18D16EC9152ABC5892E9ADC744C61C7A3488F35125B7036A4850CA7B7C63F03A9C2D776949E95D53D61EB2814BD103DEBF15F5282B2EE3D6368F797DF694F039CE9C560AA3A9363AA12A96A60D3EA1B15496D688C7F4CD7C095FBC39EF9F3CE8AD2AC71E67383413E07DA6CEB34292AE7A87DA19F4DA4501FA81801BF19E129A6802B4EE00051C9E35E648B9EE8A4BB32A95DA132C5BAC253BD0D494AE53200256E9C1DAB40E3DD04286091BBB6BA5E0274C807F0A2AB86AE9A05B552AB2DA53C8811D6FA9A49C1584827009EDDB53AD43D26EAAEE4526DE86C03D952A429C3F82427F3D3AEF898CD47A3D704B88E7891E4521D75A5E08DC953648383CF63E7A9B2CDE98D36E58D4395226C96A25429EFA9D505246C9697C32DB638F849524E0F3F5D5A61331CB0BE617B4AE43E5E41B1958BEBBDF53EA51809F16334A7900B71E321208DC32372B7103EBAA33EDAD487028D4FF00F3C67FE35255C1408D41168B2843A6A73A0B52E72547780B5B84212941FE8A7B79E74E8F604ADE3F8BD2BB8FD4985FF6E99CB8A021AE60006D0A0924B21C6D1BDE97C552174D2E89D1237B2EB34871A68EE5A1F4A4AFC3214938C1F757E6383A57B576DE7EC9833245F2F256FD3D53DC"
    F_TXT$ = F_TXT$ & "8CDC18EB77C30D1732819ED91B72ADBC918C8D39A351E057AA37B532B1193220C8951D2EB4B25208119A23907230403C691E6A56ED52BD313D25B0DDACC6A4ABD5645C532BCEC086DA871E1B6E1565C1C81EEE383E6082737930C8F92DA6850F242D8F4AEA5858D8A639A3B7D937C5AED55016EEDBDE82D6E7BDEFBB668A996EDE0E3EFAE4290D3261308CA4250A05493EF670E00400402082754ED25E33287024BF82EBF1DB7178E064A413A9AE9E9B598BBA9D6EF556C0728126A8FA9BA7CF6EB4E4E8521E241282B0ACB6E2891C2B93C67B8D534D3296186D9646C6DB484A103B240E00D731E2923712E3AFD93F6A3D5F3F0F2A18DB0474E04D9E2D6DDD50FC7D28963D723DB7D53A855E440F5E5C496FAE3B457B5297B71085AB839093CE3E606B96E8BA5374D3E8AECE65E35E851CC699354A0532D0092DA88EE140120E7BEA87AE7A3D5BB559D265C5A8D4E1C890E29C5FBE8711B89C9E08CFEFD05D47D1A6A8DE7D9370437C7926530A6CFE292AFCB532C7F6583930F2402D02C15C3684E98DF4A2586AA171361B5C50811680DBE1B04B990D13FCAA4F9A8FC3C7CF4D6B35D71F9365AE43D35E7554FA86E727434C5795FA56BE2693C27FDC60EBBAD0E9D2A8F675329F53AA551336333B1D10AA8FA19CE4FC2904607DDA26A75AB0A9"
    F_TXT$ = F_TXT$ & "B534CF4BF5093290DA9A42E6CD71FF000D2A20A824289033B539FD9A20042B18207B0349F416B52B328158A82E6D4A951DF96B484ADD564294076CE0F38D79717A6D418B59725A5A79714A90E374D71D2A8ADBA9180E86CF75F6E5590300800F3A34D66BBC1B7749BF8D9774853A8C31D2DBA3FBB1FF00F41D47D47BFEA547B3A350A2B2D7851EA8DD490F9510BCA1495787FD52A483AB76B34B8F5BA24DA64EDE62CD654CBBB15B55B5430707C8E3494A87A33D09D24D2AB7528BF24BC943C3F249FDFAB5C19E08D85937BB4B64C52BDC1D1A41DD5733B795F6E566445446121C65088C9CB896D0909484F001576270319CE34E7F6441DE3F80A9A30A1FA91501E7FDAEBCD73D1B2BD16A31DC835CA73ECB6EA164AD0B69600502718DC33C71A7B7D8ECF3F68AE3FF001FFF009D1B2B2A121AD8CE8214304964BC206BFA4CC87D3AEB0BF4B2A4CA6E2650A470523D49BDC47EC4E4E9134E6AD0170F48A8B7ACA8AC74F99B4BDA4DB72DDF0E2C99EB2AF14B872015839E0F9E07F3B06BEA65B50E991673255226FB415BA52E739E2A9EF70230ACF18DA00C6349C5F43AE0B65D31BA7D5CA33F6EA5F3262D0EE8A6898DC0709C92C39F12467CBEFC93CEAA1C413A4FB450DA9E294AA4557A4557B4EDB2A55CB57BF52BA5D3145464C765006D75"
    F_TXT$ = F_TXT$ & "493EF252946E0547B739EC75F4086024024123B9F9E812C3B3EB748A8D52AF79C9A0CFAD4F5270FD2E9498C5A4807292E72B73271F11E31A3DD83EBF8EA2A4BFFFD9"
    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$ & ".jpg": KillFile 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$
End Function

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

Sub FillDocuments_OnOpen()
    Enable_HotKeys
End Sub

Sub FillDocuments_OnClose()
    Disable_HotKeys
End Sub

Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Author: Igor Vakhnenko       Engine version: 4       Date: 07.10.2025
' ExcelVBA.ru     Professional application development for Microsoft Excel
'---------------------------------------------------------------------------------------
Option Explicit: Option Compare Text: Option Private Module

Function MailModeTXT() As String
    On Error Resume Next: MailModeTXT = Choose(SETT.GetNumber("MultiPage_SendMode") + 1, "TheBAT", "Outlook", "Unisender")
End Function

Function MailSettingsOK() As Boolean
    On Error Resume Next
    Dim EmptyFieldName$, ErrList$
    Const ListPrefix$ = "===[np][tab0.5]* [b]"
    If Trim(SETT.GetText("TextBox_MailTo")) = "" Then EmptyFieldName$ = "MailTo":  ErrList$ = ErrList$ & ListPrefix$ & tt("F_Settings\Label_" & EmptyFieldName$)
    If Trim(SETT.GetText("TextBox_MailSubject")) = "" Then EmptyFieldName$ = "MailSubject":  ErrList$ = ErrList$ & ListPrefix$ & tt("F_Settings\Label_" & EmptyFieldName$)
    If Trim(SETT.GetText("TextBox_MailBody")) = "" Then EmptyFieldName$ = "MailBody":  ErrList$ = ErrList$ & ListPrefix$ & tt("F_Settings\Label_" & EmptyFieldName$)
    If ErrList$ = "" Then MailSettingsOK = True: Exit Function
    
    ShowError tt("MsgO_4"), tt("MsgO_5") & ErrList$, tt("MsgO_6"), tt("MsgO_7") & _
        AddButton("SettError///TextBox_" & EmptyFieldName$ & "///Label_" & EmptyFieldName$, tt("MsgO_8")) & _
        AddButton("SettError///CheckBox_SendEmail", tt("MsgO_9"))
End Function

Function CMH() As String ' добавляем пункты в контекстное меню текстовых полей на форме настроек
    On Error Resume Next: Dim arr, coll As New Collection, i&, item
    If ActiveSheet Is Nothing Then Exit Function
    arr = Intersect(Rows(SETT.GetNumber("ComboBox_FirstRow")), Range("a:z")).Value
    For i = LBound(arr, 2) To UBound(arr, 2)
        If Len(Trim(arr(1, i))) Then coll.Add Trim(arr(1, i)), Trim(arr(1, i))
    Next i
    i = 0
    For Each item In coll
        item = "{" & item & "}": i = i + 1
        CMH = CMH & IIf(Len(CMH), "|", "") & "Paste~" & item & "~* " & item & "~1006~" & IIf(i = 1, 1, 0)
    Next
End Function

Function CMTemplate() As String ' добавляем пункты в контекстное меню поля Маска имени файла
    Const DefMask = "{%str%} - {%filename%}.{%ext%}", TMask = "{%filename%}.{%ext%}"
    CMTemplate = "PasteAll~" & DefMask & "~" & tt("Default filename mask") & ": " & DefMask & "~330~1|" & _
                 "Paste~" & TMask & "~" & tt("Paste template filename") & ": " & TMask & "~1028~1"
End Function

Sub ShowSheetFunction(ByVal FunctionName$)
    On Error Resume Next: Dim msg$, descr$, testv, comment$, res$, ra As Range
    Set ra = shf.ListObjects("functions").DataBodyRange.Offset(, 1)
    testv = Application.WorksheetFunction.VLookup(FunctionName$, ra, 2, 0)
    If Fix(Val(testv)) = 45507 Then testv = CDate(Val(Replace(testv, ",", ".")))
    
    descr$ = Application.WorksheetFunction.VLookup(FunctionName$, ra, 3, 0)
    comment$ = Application.WorksheetFunction.VLookup(FunctionName$, ra, 4, 0)
    res$ = RunMacro(FunctionName$ & PARAM_SEP$ & testv)
    
    ShowMsg "HIDE![iFormula][#/w]: " & te("Формула") & " [b]=[cid=fname][b]" & FunctionName$ & "[b]()"
    msg$ = "[space15]:[b]" & Replace(Replace(descr$, "\n", vbCr), Chr(10), "===[#g]") & IIf(Len(comment$), "===[frame][space15][ii][#/dfd]" & comment$, "")
    
    If ACP = 1251 Then
        msg$ = msg$ & "===[p12][b]" & te("Проверить работу функции на примере:") & "===[textbox][click=TestUDF][cid=source]" & testv & _
        "===[p12][b]" & te("Результат применения функции:") & "===[textbox][hz=200][cid=res]" & res$ & _
        "===[p9][btn][#/0f0][b][click=PasteUDF///" & FunctionName$ & "]" & tt("BtnPasteUDF")
    Else
        msg$ = msg$ & "===[p12][b][#r]" & tt("MSG_UDF_ACP") & "===" & tt("MSG_UDF_ACP2") & "===[btn][b][#w/r][click=IncorrectACPNotice]" & tt("IncorrectACP")
    End If
    ShowMsg msg$
End Sub

Sub TestUDF()
    On Error Resume Next: Dim FunctionName$, testv, res$
    FunctionName$ = GetMSGControl("fname").Caption
    testv = GetMSGControl("source").Text
    If Fix(Val(testv)) = 45507 Then testv = CDate(Val(Replace(testv, ",", ".")))
    res$ = Run(TWN & FunctionName$, testv)
    GetMSGControl("res").Text = res$
End Sub

Sub PasteUDF(ByVal FunctionName$)
    On Error Resume Next: Dim ra As Range, ar As Range, ur As Range
    Set ur = ActiveSheet.UsedRange: If ur.Columns.Count < 200 Then Set ur = ur.resize(, ur.Columns.Count + 50)
    If ur.Rows.Count < ActiveSheet.Rows.Count - 10 Then Set ur = ur.resize(ur.Rows.Count + 10)
    Set ra = Intersect(Selection, Selection, ur, Range("1:1000"))
    If ra.Rows.Count > 1 Then Set ra = Intersect(ra, Range("2:1000"))
    If ra Is Nothing Then ShowMsg "[space15][ie]:[b][#r][hidein2]" & tt("PasteUDFerr"), "pasteUDF": Exit Sub
    For Each ar In ra.Areas
        ar.FormulaR1C1Local = "=" & FunctionName$ & "(RC[" & IIf(ar.Column = 1, "", "-") & "1])"
    Next ar
    ra.Select: ra.Cells(1).Activate
    ShowMsg "[space15][iok]:[b][#g][hidein3]" & Replace(tt("PasteUDFok", ra.Address(0, 0, xlA1)), vbLf, "==="), "pasteUDF"
End Sub

Function GetWA() As Boolean
    On Error Resume Next: Dim p$, pname$, restart As Boolean, emsg$: pname$ = "Winword" & Chr(46) & Chr(101) & Chr(120) & Chr(101)
    Set WA = GetObject(, "Word.Application")
    If Not WA Is Nothing Then ' если word запущен - проверяем, не подвис ли он (если подвис - перезапускаем)
        Err.Clear: p$ = WA.path: restart = (WA.Visible = False) And (WA.documents.Count > 0)
        If (Err <> 0) Or (p$ = "") Or restart Then Set WA = Nothing: KTask pname$ Else GetWA = WA.Visible: GoTo exitWA
    End If
    Err.Clear: Set WA = CreateObject("Word.Application")
    If WA Is Nothing Then ' если Word так и не запустился
        If Err Then emsg$ = "===[#r][b]Error " & Err.Number & ": " & Err.Description
        ShowError tt("MSGT_ErrA", "Word"), tt("MSG_ErrA1", "Word"), tt("MSG_ErrA2", "Word") & emsg$, tt("MSG_RestartComp")
        Exit Function
    End If
exitWA:
    WA.Visible = False
    Err.Clear
End Function

Function GetPP() As Boolean
    On Error Resume Next: Dim p$, pname$, restart As Boolean, emsg$: pname$ = "powerpnt" & Chr(46) & Chr(101) & Chr(120) & Chr(101)
    Set PPA = GetObject(, "PowerPoint.Application")
    If Not PPA Is Nothing Then ' если PowerPoint запущен - проверяем, не подвис ли он (если подвис - перезапускаем)
        Err.Clear: p$ = PPA.path: restart = (PPA.Visible = False) And (PPA.Presentations.Count > 0)
        If (Err <> 0) Or (p$ = "") Or restart Then Set PPA = Nothing: KTask pname$ Else GetPP = PPA.Visible: GoTo exitPPA
    End If
    Err.Clear: Set PPA = CreateObject("PowerPoint.Application")
    If PPA Is Nothing Then ' если PowerPoint так и не запустился
        If Err Then emsg$ = "===[#r][b]Error " & Err.Number & ": " & Err.Description
        ShowError tt("MSGT_ErrA", "PowerPoint"), tt("MSG_ErrA1", "PowerPoint"), tt("MSG_ErrA2", "PowerPoint") & emsg$, tt("MSG_RestartComp")
        Exit Function
    End If
exitPPA:
    ' PPA.Visible = False ' недоступно
    Err.Clear
End Function

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 UpdateUDFs()
    On Error Resume Next
    If ActiveWorkbook Is Nothing Then Exit Sub

    Dim sh As Worksheet, ra As Range, cell As Range, ErrorsCount&, coll As New Collection, calc, oldPath$, item
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        Set ra = Nothing: Set ra = FindAll(sh.UsedRange, "\FillDocuments", xlFormulas, xlPart)        '& ThisWorkbook.Name & "'!", xlFormulas, xlPart)
        If Not ra Is Nothing Then
            Set coll = New Collection
            For Each cell In ra.Cells
                ErrorsCount& = ErrorsCount& + 1
                oldPath$ = GetOldAddinPathForReplace(cell.Formula)
                If Len(oldPath$) Then coll.Add oldPath$, oldPath$
            Next cell
            For Each item In coll
                sh.UsedRange.Replace item, "'" & ThisWorkbook.Name & "'", xlPart
            Next
        End If
    Next sh
    Application.Calculation = calc
    If ErrorsCount& Then
        MsgBox "Заменено формул: " & ErrorsCount&, vbInformation
    Else
        MsgBox "Не найдено некорректных формул, ссылающихся на функции надстройки FillDocuments", vbInformation
    End If
End Sub

Private Function GetOldAddinPathForReplace(ByVal txt As String) As String
    On Error Resume Next: Dim pos&, pos1&, pos2&
    pos& = InStr(1, txt, "\FillDocuments", vbTextCompare)
    If pos& = 0 Then Exit Function

    pos1& = InStrRev(txt, "'", pos, vbTextCompare)
    If pos1& = 0 Then Debug.Print "некорректная формула": Exit Function
    pos2& = InStr(pos&, txt, "'", vbTextCompare)
    If pos2& = 0 Then Debug.Print "некорректная формула": Exit Function

    GetOldAddinPathForReplace = Mid(txt, pos1, pos2 - pos1 + 1)
End Function

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 GetFilledCells(ByRef ra As Range) As Range
    ' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
    On Error Resume Next: Err.Clear
    Set GetFilledCells = ra.SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then If Not (GetFilledCells Is Nothing) Then Exit Function
    ' если лист защищён, или метод выдал ошибку
    Dim cell As Range
    ' перебираем все ячейки в диапазоне
    For Each cell In Intersect(ra, ra.Worksheet.UsedRange).Cells
        If Trim(cell.Value) <> "" Then        ' если ячейка непустая
            ' то добавляем её в результат
            If GetFilledCells Is Nothing Then
                Set GetFilledCells = cell
            Else
                Set GetFilledCells = Union(GetFilledCells, cell)
            End If
        End If
    Next cell
End Function

Function SpecialCells_VisibleRows(ByRef ra As Range) As Range
    On Error Resume Next: Err.Clear
    Set SpecialCells_VisibleRows = ra.SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then If Not (SpecialCells_VisibleRows Is Nothing) Then Exit Function
    ' если лист защищён, или метод выдал ошибку
    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
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$, Optional ByRef options As Dictionary) As String
    On Error Resume Next: Err.Clear
    Dim mask$, RelativeFilePath$, subfolder$, filename$, pcc&, NewFolderPath$, NewFilename$
    If options Is Nothing Then Set options = New Dictionary ' для отладки. в функцию ВСЕГДА передаётся словарь options
    
    mask$ = Replace(SETT.GetText("TextBox_OutputMask"), "/", "\")      ' f.e. {%str%} - {%filename%}.{%ext%}
    If InStr(1, mask$, "{%ext%}", vbTextCompare) = 0 Then mask$ = mask$ & ".{%ext%}" ' добавлено в феврале 2021 (дописываем расширение, если пользователь стёр его из маски)
    
    RelativeFilePath$ = Replace(OldFilename$, TEMPLATES_FOLDER$, "") ' относительный путь к файлу шаблона, вида  file.doc или folder1\folder2\file.doc
    
    subfolder$ = Left(RelativeFilePath$, InStrRev(RelativeFilePath$, "\") - 1)
    If Len(subfolder$) Then
        options("{%subfolder%}") = subfolder$ ' добавлено в феврале 2021
        subfolder$ = subfolder$ & "\"
    End If
    
    filename$ = GetFilename(OldFilename$, False)
    
    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(RelativeFilePath$)
    
    If InStr(1, mask$, "{%subfolder%}", vbTextCompare) = 0 Then
        NewFilename$ = OUTPUT_FOLDER$ & subfolder$ & FWF.Replace_symbols(RenderString(mask$, options), , True)
    Else ' добавлено в феврале 2021 для маски имени файла с параметром {%subfolder%}
        NewFilename$ = OUTPUT_FOLDER$ & Replace(FWF.Replace_symbols(RenderString(mask$, options), , True), "\{%subfolder%}\", "\")
    End If
    NewFilename$ = Replace(Replace(Replace(NewFilename$, vbNewLine, ""), Chr(13), ""), Chr(10), "")
    
    ' создание папки для файла
    NewFolderPath$ = Left(NewFilename$, InStrRev(NewFilename$, "\"))
    MkDir NewFolderPath$
    
    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 "PPTX": GetFileFormatForNewFile = 24        ' ppSaveAsOpenXMLPresentation
        Case "PPT": GetFileFormatForNewFile = 1        ' ppSaveAsPresentation
        
        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 = 3
            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 = 3
            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.MergeArea.Cells(1)) = 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 FillInThisWorksheet(ByRef sh As Worksheet) As Boolean
    On Error Resume Next: FillInThisWorksheet = True: Dim NamesList$
    If Not SETT.GetBoolean("CheckBox_SpecifiedTemplateWorksheets") Then Exit Function
    NamesList$ = Replace(SETT.GetText("TextBox_SpecifiedTemplateWorksheets"), " ", "")
    If NamesList$ = "" Then Exit Function
    FillInThisWorksheet = "," & NamesList$ & "," Like "*," & Replace(sh.Name, " ", "") & ",*"
End Function

Function CreateAndFill_XLS(ByVal TemplateFilename$, ByVal NewFilename$, ByRef AllOptions As Dictionary) 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
    
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Main_PI.ShowLine 3, 2, 100, tt("PI_CreateXLS")
    
    If TemplateType(TemplateFilename$) Like "*template*" Then
        Set Wb = Application.Workbooks.Add(TemplateFilename$)
    Else
        Set Wb = Application.Workbooks.Open(TemplateFilename$, False, True)
    End If
    
    If SETT.GetBoolean("CheckBox_ReplaceExistingFieldCodesOnly") Then
        Main_PI.ShowLine 3, 6, 100, tt("PI_TLoadCodes")
        Set options = GetTemplateOptions(AllOptions, LoadFieldCodes_Excel(Wb))
    Else
        Set options = AllOptions
    End If
    
    If SETT.GetBoolean("CheckBox_MultiRow") Then        ' размножение специальных строк в шаблоне
        Main_PI.ShowLine 3, 10, 25, tt("PI_m15") ' "Размножение строк (с закладками MULTIROW)"

        Dim rc&: rc = Val(AllOptions("{%rc%}"))
        If rc& = 0 Then LRec.AddRecord te("Ошибка при подготовке документа Excel"), "rc& = 0", 1: Exit Function
        
        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) And FillInThisWorksheet(ra.Worksheet) 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
    
    Main_PI.StartActions 3, IIf(SETT.GetBoolean("CheckBox_MultiRow"), 25, 10), 75, tt("PI_m16"), options.Count  ' "Подстановка значений в созданный по шаблону документ"
    Dim RIC As Boolean, arr, key$, txt As Variant, File_Format, nn As Name
    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 FillInThisWorksheet(sh) Then
                If HasLinkToObject(txt, key$) Then
                    InsertObjectIntoXLS sh, txt, key$
                    Err.Clear
                Else
                    sh.UsedRange.Replace key$, txt, xlPart, , False
                    If RIC Then
                        With sh.PageSetup
                            If InStr(1, .LeftFooter, key$) > 0 Then .LeftFooter = Replace(.LeftFooter, key$, txt, , , vbTextCompare)
                            If InStr(1, .LeftHeader, key$) > 0 Then .LeftHeader = Replace(.LeftHeader, key$, txt, , , vbTextCompare)
                            If InStr(1, .CenterFooter, key$) > 0 Then .CenterFooter = Replace(.CenterFooter, key$, txt, , , vbTextCompare)
                            If InStr(1, .CenterHeader, key$) > 0 Then .CenterHeader = Replace(.CenterHeader, key$, txt, , , vbTextCompare)
                            If InStr(1, .RightFooter, key$) > 0 Then .RightFooter = Replace(.RightFooter, key$, txt, , , vbTextCompare)
                            If InStr(1, .RightHeader, key$) > 0 Then .RightHeader = Replace(.RightHeader, key$, txt, , , vbTextCompare)
                        End With
                    End If
                End If
            End If
        Next sh
        
        Main_PI.Action 3, tt("PI_ReplacingCode ") & i + 1 & " / " & UBound(arr) + 1 & ": " & key$ & " = " & Left(txt, 50)
    Next i
    
    Main_PI.StartActions 3, 75, 84, tt("PI_ReCalc"), Wb.Worksheets.Count
    For Each sh In Wb.Worksheets
        Main_PI.Action 3, tt("PI_ReCalc") & ": " & sh.Name
        If FillInThisWorksheet(sh) And sh.Visible Then
            Main_PI.ShowLine 4, 1, 4, tt("sheet") & " «" & sh.Name & "»: " & tt("Calculation")
            sh.Calculate
            Main_PI.ShowLine 4, 3, 4, tt("sheet") & " «" & sh.Name & "»: " & tt("FormulasToValues")
            If SETT.GetBoolean("CheckBox_FormulasToValues") Then sh.UsedRange.Value = sh.UsedRange.Value
        End If
    Next sh
    Main_PI.ShowLine 3, 84, 86, tt("PI_xlAutoFit")
    For Each nn In Wb.Names
        If nn.Name Like "AutoFitMergedCells*" Then AutoFitMergedCellRowHeight nn.RefersToRange
    Next nn
    
    If SETT.GetBoolean("CheckBox_ToDelete_Enabled") Then
        Main_PI.ShowLine 3, 86, 90, tt("PI_xlRangeToDel")
        FindRangesToDelete Wb
        ' удаление столбцов, в которых присутствуют ячейки со значением "DeleteColumn"
        For Each sh In Wb.Worksheets
            Set ra = Nothing: Set ra = FindAll(sh.UsedRange, "DeleteColumn", , xlWhole).EntireColumn
            Intersect(ra, ra).EntireColumn.Delete
            sh.UsedRange.Find "", , , xlPart ' сброс настроек поиска
        Next sh
    End If
    
    Application.Run "'" & Wb.Name & "'!FillDone"
    
    Main_PI.ShowLine 3, 90, 100, tt("PI_Saving") & ": " & GetFilename(NewFilename$)
    LRec.AddRecord te("Сохранение созданного файла"), Replace(NewFilename$, OUTPUT_FOLDER$, "...\"), 1
    If Trim(Wb.BuiltinDocumentProperties(5)) = "" Then Wb.BuiltinDocumentProperties(5) = tt("FILE_COMMENT")
    
    Err.Clear
    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
    Dim errN&, errD$: errN& = Err.Number: errD$ = Err.Description
    If Err Then LRec.AddRecord te("ОШИБКА ") & errN&, errD$, 1

ExitFillXLS:
    CreateAndFill_XLS = errN& = 0
    
    If SETT.GetBoolean("CheckBox_ImmediatePrintOut") Then Main_PI.ShowLine 3, 96, 100, tt("PI_Printout"): Wb.PrintOut , , PrintCopiesCount(AllOptions)
    Main_PI.ShowLine 3, 100, 100, tt("PI_ClosingDoc")
    Wb.Close False
    
    Application.Calculation = calc
    Application.DisplayAlerts = True
End Function

Sub AutoFitMergedCellRowHeight(ByRef ra As Range)
    Dim cell As Range, ma As Range, col As Range, ro As Range, maxRH, newCW, cw, rh
    For Each ro In ra.Rows
        maxRH = 0
        For Each cell In ro.Cells
            If cell.MergeCells And cell.Address = cell.MergeArea.Cells(1).Address Then
                Set ma = cell.MergeArea: newCW = 0
                With ma
                    cw = .Columns(1).ColumnWidth: .UnMerge
                    For Each col In .EntireColumn: newCW = newCW + col.ColumnWidth: Next
                    .Columns(1).ColumnWidth = newCW: .EntireRow.AutoFit
                    rh = .EntireRow.RowHeight: If rh > maxRH Then maxRH = rh
                    .Merge: .Columns(1).ColumnWidth = cw
                End With
            End If
        Next cell
        If maxRH > 0 Then ro.EntireRow.RowHeight = maxRH
    Next ro
End Sub

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) As Boolean
    On Error Resume Next: Err.Clear
    Dim doc As Object, ecount As Long, bm As Object, PasteRange As Object, myStoryRange As Object, i&, oFirstCellRange As Object, bmText$, options As Dictionary
    Main_PI.ShowLine 3, 2, 100, tt("PI_m13")  ' "Создание документа Word по шаблону"
    
…