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
'---------------------------------------------------------------------------------------
' Author        : Igor Vakhnenko                   Date: 25.12.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    If Not Developer Then ThisWorkbook.Saved = True

    DeleteProgramCommandBar
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 CreateTemplateSamplesOnFirstRun
    CreateProgramCommandBar 0
End Sub


Attribute VB_Name = "template2"
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 = "clsCode128"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm


' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        .BarSpacePattern = Replace(BarSpacePattern, " ", "")
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    Code128_Str = Replace(BuildStr(Str), " ", "")
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = Trim(BuildStr) & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function




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

Option Explicit: Option Compare Text: Option Private Module
Public sht As Worksheet, pi As ProgressIndicator

Sub CreateLabels()
    On Error Resume Next
    Dim ra As Range, ro As Range, n&, SheetNameSuffix$, pi As ProgressIndicator, rc&
    Set ra = GetRows()
    If ra Is Nothing Then Exit Sub

    If SETT.GetBoolean("CheckBox_SeparatelyByRows") Then
        Set pi = New ProgressIndicator
        pi.Show "Формирование этикеток для отдельных строк", -1
        rc& = Intersect(Columns(1), ra.EntireRow, ra.EntireRow).Cells.Count
        pi.StartNewAction , , , , , rc&

        For Each ro In Intersect(ra.EntireRow, ra.EntireRow).Rows
            n = n + 1: SheetNameSuffix$ = " " & n
            pi.SubAction "Строка $index из $count", "Номер строки на листе: " & ro.Row
            If Not CreateLabelsForRange(ro, SheetNameSuffix$) Then Exit Sub
        Next
        pi.Hide
    Else
        CreateLabelsForRange ra
    End If

    If SETT.GetBoolean("CheckBox_SaveSheetAsFile") Then
        OpenFolder OUTPUT_FOLDER$
    End If

End Sub

Function CreateLabelsForRange(ByRef ra As Range, Optional SheetNameSuffix$) As Boolean
    On Error Resume Next
    Dim TemplateRange As Range, SourceSheet As Worksheet, msg$, NewFilename$, filename$
    Set SourceSheet = ActiveSheet

    Dim LC As Long: LC = CalculateLabelsCount(ra)        ' количество этикеток
    If LC = 0 Then
        msg$ = "В настройках программы задан столбец с количеством этикеток." & vbNewLine & _
               "В указанном столбце, числовые значения не найдены, потому программа не может определить, сколько этикеток надо напечатать"
        MsgBox msg, vbExclamation, "Проверьте настройки программы"
        FormSetError F_Settings, "ComboBox_CountColumn", "CheckBox_AmountColumn"
        Exit Function
    End If

    If SETT.GetBoolean("CheckBox_ShowConfirmationMessage") Then
        msg = "Будет сформировано этикеток: " & LC & " (для каждой из выделенных в данный момент строк)" & vbNewLine & _
              "Процесс формирования листа с этикетками может занять некоторое время" & vbNewLine & vbNewLine & _
              "Начать заполнение этикеток?"
        If MsgBox(msg, vbQuestion + vbOKCancel + vbDefaultButton1, "Подтвердите запуск макроса") = vbCancel Then Exit Function
    End If
    DoEvents

    Application.ScreenUpdating = False
    Set sht = Nothing: Set TemplateRange = Nothing
    Set sht = LoadActiveTemplate()
    If sht Is Nothing Then Application.ScreenUpdating = True: Exit Function
    Set TemplateRange = GetTemplateRange(sht)
    If TemplateRange Is Nothing Then GoTo ExitLabel


    Set pi = New ProgressIndicator
    pi.Show "Формирование листа с этикетками"

    Dim sh As Worksheet: Set sh = CreateLabelsWorksheet(SheetNameSuffix$)
    If sh Is Nothing Then
        MsgBox "Ошибка подготовки листа для этикеток", vbExclamation, "Обратитесь к разработчику программы"
        GoTo ExitLabel
    End If

    If Not TaggingSheet(sh, TemplateRange, LC) Then
        MsgBox "Ошибка разметки листа под этикетки", vbExclamation, "Обратитесь к разработчику программы"
        GoTo ExitLabel
    End If

    ActiveWindow.View = xlNormalView
    If Not CloneTemplateAndFillInLabels(sh, TemplateRange, ra, LC) Then
        MsgBox "Ошибка заполнения этикеток", vbExclamation, "Обратитесь к разработчику программы"
        GoTo ExitLabel
    End If
    ActiveWindow.View = xlPageBreakPreview

    If SETT.GetBoolean("CheckBox_FormulasToValues") Then
        sh.UsedRange.Value = sh.UsedRange.Value
    End If

    Application.DisplayAlerts = False
    If SETT.GetBoolean("CheckBox_AutoPrint") Then
        sh.PrintOut
        RunWithDelay "SetFocusToExcel"
    End If

    filename$ = Render(SETT.GetText("TextBox_OutputFilename"), ra.Rows(1).EntireRow)
    If filename$ = "" Then filename$ = Format(Now, "YYYY-MM-DD HH-NN-SS")

    If SETT.GetBoolean("CheckBox_SaveSheetAsFile") Then
        If SETT.GetBoolean("CheckBox_PDF") And (Val(Application.Version) > 11) Then
            NewFilename$ = OUTPUT_FOLDER$(True) & filename$ & ".pdf"
            sh.Parent.ExportAsFixedFormat 0, NewFilename$    ' xlTypePDF = 0
            sh.Parent.Close False
            'FWF.ShowFile NewFilename$
        Else
            NewFilename$ = OUTPUT_FOLDER$(True) & filename$ & ".xls"
            sh.Parent.SaveAs NewFilename$, xlWorkbookNormal
        End If
    End If
    Application.DisplayAlerts = True
    CreateLabelsForRange = True

ExitLabel:
    pi.Hide: DoEvents
    sht.Parent.Close False        ' закрываем файл шаблона

    If SETT.GetBoolean("CheckBox_ExternalRun") Then
        SourceSheet.Parent.Activate
        SourceSheet.Activate
        RunWithDelay "SetFocusToExcel"
    End If
    Application.ScreenUpdating = True
    ' sh.PrintPreview
End Function

Sub SetFocusToExcel()
    On Error Resume Next
    AppActivate Application.Name
End Sub

Function CloneTemplateAndFillInLabels(ByRef sh As Worksheet, ByRef tr As Range, ByVal AllRows As Range, ByVal LC&) As Boolean
    ' tr - ссылка на диапазон-шаблон
    On Error Resume Next
    Dim ra As Range, i&, ro As Range, CountColumn&, calc As XlCalculation, cnt&, iter&
    Application.ScreenUpdating = False
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual

    pi.StartNewAction 30, 100, "Заполнение этикеток...", " ", " ", LC
    Dim ReplaceFields As Collection, ReplaceField: Set ReplaceFields = RangeFieldsNames(tr)
    Dim cell As Range, RowsForHide As Range, ColumnsForHide As Range

    If SETT.GetBoolean("CheckBox_AmountColumn") Then CountColumn& = SETT.GetNumber("ComboBox_CountColumn")

    For Each ro In AllRows.EntireRow
        If Not ro.EntireRow.Hidden Then
            cnt& = 1: If CountColumn& Then cnt& = Abs(Fix(Val(ro.Cells(CountColumn&))))

            For iter& = 1 To cnt&
                i = i + 1: DoEvents
                pi.SubAction , "Заполняется этикетка " & i & " из " & LC & ""
                Set ra = Nothing        ' ищем место на листе для очередной этикетки
                Set ra = sh.UsedRange.Find("# " & i, , xlValues, xlWhole).Resize(tr.Rows.Count, tr.Columns.Count)
                tr.Copy ra        ' копируем шаблон этикетки
                'ra.Value = tr.Value    ' для тестирования скорости

                ' запоминаем строки для последующего скрытия, если в ячейках нулевое или пустое значение
                Set RowsForHide = Nothing: Set ColumnsForHide = Nothing
                Set RowsForHide = FindAll(ra, "{СкрытьСтроку}", , xlPart)
                Set ColumnsForHide = FindAll(ra, "{СкрытьСтолбец}", , xlPart)
                ' удаляем метки из полей
                ra.Replace "{СкрытьСтроку}", "", xlPart
                ra.Replace "{СкрытьСтолбец}", "", xlPart

                For Each ReplaceField In ReplaceFields
                    ReplaceFieldInRange ra, ReplaceField, ro, i
                Next ReplaceField

                ' перебираем все ячейки, и скрываем строки или столбцы,
                ' если в ячейках нулевое или пустое значение
                For Each cell In RowsForHide.Cells
                    If Len(Trim(cell)) = 0 Or (IsNumeric(cell) And Val(cell) = 0) Then        ' если ячейка пустая
                        cell.EntireRow.Hidden = True
                    End If
                Next cell
                For Each cell In ColumnsForHide.Cells
                    If Len(Trim(cell)) = 0 Or (IsNumeric(cell) And Val(cell) = 0) Then        ' если ячейка пустая
                        cell.EntireColumn.Hidden = True
                    End If
                Next cell
            Next iter&
        End If
    Next ro
    Application.Calculation = calc
    CloneTemplateAndFillInLabels = True
End Function



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

'Option Compare Text: Option Explicit: Option Private Module

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

Function OUTPUT_FOLDER$(Optional ByVal CreateFolderIfNotExist As Boolean = False)
    On Error Resume Next
    outputFolder$ = ThisWorkbook.Path & "\Files\"
    If SETT.GetText("TextBox_OutputFolder") = "" Then
        SETT.SetText "TextBox_OutputFolder", outputFolder$
    End If
    If CreateFolderIfNotExist Then If Dir(outputFolder$, vbDirectory) = "" Then MkDir outputFolder$

    OUTPUT_FOLDER$ = SETT.GetText("TextBox_OutputFolder")
End Function

Function RangeFieldsNames(ByVal ra As Range) As Collection
    On Error Resume Next
    txt$ = Replace(Range2TXT(ra), "}", "}" & vbNewLine)
    Set REGEXP = CreateObject("VBScript.RegExp")
    REGEXP.Global = True: REGEXP.Pattern = "\{.{1,}\}"
    If REGEXP.test(txt$) Then Set res = REGEXP.Execute(txt$)

    Dim coll As New Collection, field As String
    For Each Item In res
        field = Item.Value: coll.Add field, field
    Next
    Set RangeFieldsNames = coll
End Function

Function Range2TXT(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = vbTab, _
                   Optional ByVal RowsSeparator$ = vbNewLine) As String
    If ra.Cells.Count = 1 Then Range2TXT = ra.Value & RowsSeparator$: Exit Function
    If ra.Areas.Count > 1 Then
        Dim ar As Range
        For Each ar In ra.Areas
            Range2TXT = Range2TXT & Range2TXT(ar, ColumnsSeparator$, RowsSeparator$)
        Next ar
        Exit Function
    End If
    arr = ra.Formula
    For i = LBound(arr, 1) To UBound(arr, 1)
        txt = "":
        For j = LBound(arr, 2) To UBound(arr, 2)
            txt = txt & ColumnsSeparator$ & arr(i, j)
        Next j
        Range2TXT = Range2TXT & Mid(txt, Len(ColumnsSeparator$) + 1) & RowsSeparator$
    Next i
End Function

Function RepeatRange(ByRef SourceRange As Range, ByVal Count As Long, _
                     ByVal Offset As Long, ByVal Direction As XlDirection) As Range
    ' функция получает в качестве параметра диапазон SourceRange,
    ' количество повторений диапазона Count, и шаг смещения Offset
    ' Возвращает диапазон, являющийся объединением копий диапазона SourceRange,
    ' смещённого на Offset ячеек Count раз в направлении Direction.

    Select Case Direction
        Case xlDown: OffsetX = 0: OffsetY = Offset
        Case xlUp: OffsetX = 0: OffsetY = -Offset
        Case xlToRight: OffsetX = Offset: OffsetY = 0
        Case xlToLeft: OffsetX = -Offset: OffsetY = 0
    End Select

    Set RepeatRange = SourceRange
    For i = 1 To Count - 1
        Set RepeatRange = Union(RepeatRange, SourceRange.Offset(OffsetY * i, OffsetX * i))
    Next i
End Function


Function TaggingSheet(ByRef sh As Worksheet, tr As Range, ByVal LC As Long) As Boolean
    ' Макрос подготавливает лист sh к копированию этикеток количеством LC
    ' (формируются отступы между этикетками, устанавливаются нужные размеры строк и столбцов,
    ' рисуются линии для обрезки, размечаются места вставки этикеток)

    On Error Resume Next
    pi.StartNewAction 5, 10, "Форматирование листа для этикеток..."

    Dim count_w As Long, count_h As Long        ' количество этикеток на печатном листе
    Dim UseIndents As Boolean        ' надо ли добавлять отступы между этикетками
    Dim IndentWidth As Double        ' ширина отступа в миллиметрах
    Dim CutLine As Boolean        ' нужна ли линия для обрезки между этикетками
    Dim CutLineType As XlLineStyle        ' тип линии между этикетками

    ' загружаем опции из настроек программы
    count_w = SETT.GetNumber("ComboBox_count_w", 2)
    count_h = SETT.GetNumber("ComboBox_count_h", 3)

    UseIndents = SETT.GetBoolean("CheckBox_UseIndents")
    IndentWidth = SETT.GetNumber("ComboBox_IndentWidth", 10)

    CutLine = SETT.GetBoolean("CheckBox_CutLine")
    CutLineType = xlContinuous: If SETT.GetBoolean("OptionButton_LineDotted") Then CutLineType = xlDot

    ' проверяем, всё ли правильно
    Dim tw As Long, th As Long        ' размеры этикетки в ячейках
    tw = tr.Columns.Count: th = tr.Rows.Count

    msg = "Слишком большой размер диапазона этикетки: " & _
          th & " строк на " & tw & "столбцов" & vbNewLine & vbNewLine & _
          "Вы уверены, что вы верно задали диапазон в настройках программы?"
    If th > 100 Then If MsgBox(msg, vbQuestion + vbYesNo + vbDefaultButton2, "Продолжить?") = vbNo Then Exit Function
    If tw > 50 Then If MsgBox(msg, vbQuestion + vbYesNo + vbDefaultButton2, "Продолжить?") = vbNo Then Exit Function


    Dim sepW As Double, sepH As Double        ' размеры отступов (столбцов и строк)
    ' только не пытайтесь понять, что за скрытый смысл заложен в следующей строке )))
    sepW = IndentWidth * 100 / 208 / 2 * IndentWidth / (IndentWidth + Log(150 / IndentWidth) * 2)
    sepH = IndentWidth * 100 / 39 / 2

    ' пробуем разметить лист, проверяя, влезут ли все этикетки

    sh.UsedRange.Clear
    'ActiveWindow.View = xlPageBreakPreview
    sh.ResetAllPageBreaks
    With sh.PageSetup
        .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False
    End With

    ' count_w As Long, count_w As Long    ' количество этикеток на печатном листе
    ' tw As Long, th As Long              ' размеры этикетки в ячейках
    ' UseIndents As Boolean               ' надо ли добавлять отступы между этикетками


    BlocksCountX = count_w
    BlocksCountY = Application.WorksheetFunction.RoundUp(LC / count_w, 0)
    D = IIf(UseIndents, 2, 0)        ' количество строк или столбцов между блоками

    BlocksHeight = BlocksCountY * th + (BlocksCountY - 1) * D
    BlocksWidth = BlocksCountX * tw + (BlocksCountX - 1) * D


    pi.StartNewAction 10, 15, "Формируем отступы между этикетками ...", , , BlocksCountY
    ' форматируем разделители блоков
    If UseIndents Then

        pi.SubAction , "форматируем горизонтальные разделители ..."
        For i = 1 To BlocksCountX - 1
            With sh.Cells(1, 1 + i * tw + (i - 1) * D)
                .Resize(, 2).ColumnWidth = sepW
                If CutLine Then
                    .Resize(BlocksHeight).Borders(xlEdgeRight).LineStyle = CutLineType
                    .Resize(BlocksHeight).Borders(xlEdgeRight).Weight = xlThin
                End If
            End With
        Next

        For i = 1 To BlocksCountY - 1
            pi.SubAction , "форматируем вертикальные разделители ...", _
                         "Обрабатывается блок " & i & " из " & BlocksCountY - 1 & ""
            DoEvents
            With sh.Cells(1 + i * th + (i - 1) * D, 1)
                .Resize(2).RowHeight = sepH
                If i Mod count_h = 0 Then        ' надо вставлять разрыв страницы
                    Err.Clear
                    sh.HPageBreaks.Add .Offset(1)
                    'If Err Then Debug.Print Err.Number, Err.Description
                    .Offset(1).EntireRow.Hidden = True
                Else        ' разрыв внутри листа
                    If CutLine Then
                        .Resize(, BlocksWidth).Borders(xlEdgeBottom).LineStyle = CutLineType
                        .Resize(, BlocksWidth).Borders(xlEdgeBottom).Weight = xlThin
                    End If
                End If
            End With
        Next
    End If
    ActiveWindow.View = xlNormalView

    pi.StartNewAction 15, 35, "Расставляем этикетки на листе ...", " ", " ", BlocksCountY + BlocksCountX
    ' рисуем блоки
    For i = 1 To LC
        'Debug.Print "===========  этикетка # " & i

        ' позиция блока на листе
        currX = 1 + ((i - 1) Mod count_w): currY = 1 + (i - 1) \ count_w
        'Debug.Print "позиция блока на листе: ", currX, currY

        cellX = 1 + (currX - 1) * (tw + D): cellY = 1 + (currY - 1) * (th + D)
        'Debug.Print "Первая ячейка:   cellX = " & cellX & ",   cellY = " & cellY

        sh.Cells(cellY, cellX) = "# " & i
        sh.Cells(cellY, cellX).Resize(th, tw).BorderAround xlContinuous, xlMedium

        Err.Clear
        If currY = 1 Then        ' блок из первого ряда - подстраиваем ширину столбцов
            pi.SubAction "изменение ширины столбцов ...", _
                         "Обрабатывается блок " & currX & " из " & BlocksCountX & ""

            tr.Rows(1).Copy
            sh.Cells(cellY, cellX).PasteSpecial xlPasteColumnWidths
        End If

        If currX * currY = 1 Then        ' блок из первого столбца - подстраиваем высоту строк
            For r = 1 To tr.Rows.Count
                pi.SubAction "изменение высоты строк ...", _
                             "Обрабатывается строка " & r & " из " & tr.Rows.Count & ""
                RepeatRange(sh.Rows(cellY).Offset(r - 1), BlocksCountY, th + D, xlDown).RowHeight = _
                tr.Rows(r).RowHeight
            Next r
        End If

        sh.Cells(cellY, cellX) = "# " & i
        'pi.Line3 = "Блок " & i & " из " & lc & " - копирование диапазона..."
        'tr.Copy sh.Cells(cellY, cellX)
    Next i

    ActiveWindow.Zoom = 100
    sh.Cells(1).Select

    TaggingSheet = True
End Function

Function CreateLabelsWorksheet(ByVal SheetNameSuffix$) As Worksheet
    ' удаляем лист с этикетками, если он был создан ранее

    On Error Resume Next: Err.Clear
    pi.StartNewAction 0, 5, "Подготовка листа для этикеток...", "Идёт копирование и очистка листа-шаблона"
    Application.DisplayAlerts = False
    Worksheets(SHEET_NAME).Delete
    Application.DisplayAlerts = True

    Dim sh As Worksheet, WorksheetNumber&        ', WB As Workbook
    If SETT.GetBoolean("CheckBox_SaveSheetAsFile") Then
        sht.Copy: DoEvents

        If ActiveWorkbook.Worksheets.Count > 1 Or ActiveWorkbook.Path <> "" Then
            msg = "Не удалось произвести копирование листа-шаблона в новый файл"
            MsgBox msg, vbExclamation, "Ошибка формирования этикеток": Exit Function
        End If

        Set sh = ActiveWorkbook.Worksheets(1)
        If sh.Name <> sht.Name Then
            msg = "Не удалось произвести копирование листа-шаблона в новый файл"
            MsgBox msg, vbExclamation, "Ошибка формирования этикеток": Exit Function
        End If
        ' NewFilename$ = OUTPUT_FOLDER$(True) & Format(Now, "YYYY-MM-DD HH-NN-SS") & ".xls"
    Else
        WorksheetNumber& = ActiveWorkbook.Worksheets.Count
        sht.Copy , ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count): DoEvents
        Set sh = ActiveSheet
        If ActiveWorkbook.Worksheets.Count <> WorksheetNumber& + 1 Then
            msg = "Не удалось произвести копирование листа-шаблона в текущий файл" & vbNewLine & _
                  "Возможно, ваша книга Excel защищёна. Снимите защиту, и снова запустите макрос"
            MsgBox msg, vbExclamation, "Ошибка формирования этикеток": Exit Function
        End If
    End If
    sh.Name = SHEET_NAME & SheetNameSuffix$
    sh.Tab.Color = vbGreen
    sh.UsedRange.Clear        ' предварительная полная очистка листа
    sh.Shapes.SelectAll: Selection.Delete

    Set CreateLabelsWorksheet = sh
End Function

Function GetRows() As Range
    On Error Resume Next: Err.Clear
    Dim ra As Range, HeaderRowsCount As Long, SelectedRows As Range, CheckColumn As Range
    Set ra = ActiveSheet.UsedRange
    msg = "Сначала откройте таблицу с исходными данными, а потом запускайте макрос"
    If Err Then MsgBox msg, vbExclamation, "Продолжение невозможно": Exit Function

    HeaderRowsCount = Val(SETT.GetBoolean("ComboBox_FirstRow")) - 1

    If HeaderRowsCount > 0 Then
        ' берем только строки ниже заголовка
        Set ra = Intersect(ra, ra.Worksheet.Range((HeaderRowsCount + 1) & ":" & ra.Worksheet.Rows.Count))
        msg = "Нет заполненных строк ниже заголовка" & vbNewLine & "(заголовок состоит из " & HeaderRowsCount & " строк)"
        If ra Is Nothing Then MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function
    End If

    If Not SETT.GetBoolean("CheckBox_UseAllRows") Then
        ' берем только выделенные строки (если выделена хотя бы одна ячейка строки)
        Set SelectedRows = Intersect(Selection.EntireRow, Selection.EntireRow)
        msg = "Не выделен диапазон строк для обработки" & vbNewLine & "(вызможно, выделен какой-либо объект, а не диапазон ячеек)"
        If SelectedRows Is Nothing Then MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function

        Set ra = Intersect(ra, SelectedRows)
        msg = "Выделены пустые строки, или строки заголовка таблицы" & vbNewLine & _
              "(выделите заполненные строки, и снова запустите макрос)" & vbNewLine & vbNewLine & _
              "Заголовок состоит из " & HeaderRowsCount & " строк (указано в настройках)"
        If ra Is Nothing Then MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function
    End If

    BaseColumn& = SETT.GetNumber("ComboBox_BaseColumn")
    If BaseColumn& Then
        msg = "Неверно задан обязательный для этикеток столбец" & vbNewLine & "(указан столбец " & BaseColumn& & ", недоступный на листе)"
        Err.Clear: Set CheckColumn = ActiveSheet.Columns(BaseColumn&)
        If Err Then MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function

        Set CheckColumn = Range(Cells(HeaderRowsCount + 1, col), Cells(Rows.Count, col).End(xlUp))
        If CheckColumn.Row < HeaderRowsCount + 1 Then
            msg = "Обязательный для этикеток столбец не содержит заполненных ячеек в выделенном диапазоне" & _
                  vbNewLine & "(проверяемый диапазон: " & CheckColumn.Address & ")"
            MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function
        End If

        Set CheckColumn = Intersect(CheckColumn, ra.EntireRow)
        If CheckColumn Is Nothing Then
            msg = "Обязательный для этикеток столбец (его заполненная часть) не пересекается с выделенным диапазоном ячеек" & _
                  vbNewLine & "(проверяемый обязательный диапазон: " & CheckColumn.Address & ")"
            MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function
        End If

        Dim cell As Range: Set ra = Nothing
        For Each cell In CheckColumn.Cells
            If Len(Trim(cell)) > 0 And Not (IsNumeric(cell) And Val(cell) = 0) Then        ' если ячейка непустая
                ' добавляем строку в диапазон для формирования этикеток
                If ra Is Nothing Then Set ra = cell Else Set ra = Union(cell, ra)
            End If
        Next cell

        If ra Is Nothing Then
            msg = "Обязательный для этикеток столбец содержит только пустые ячейки" & _
                  vbNewLine & "(проверяемый диапазон: " & CheckColumn.Address & ")"
            MsgBox msg, vbInformation, "Продолжение невозможно": Exit Function
        End If

    End If

    ra.EntireRow.Select
    Set GetRows = ra.EntireRow
End Function

Function CalculateLabelsCount(ByVal ra As Range) As Long
    ' подсчитываем кол-во строк в несмежном диапазоне
    On Error Resume Next
    Dim CountColumn&, ro As Range, cnt&
    If SETT.GetBoolean("CheckBox_AmountColumn") Then CountColumn& = SETT.GetNumber("ComboBox_CountColumn")
    For Each ro In ra.Rows
        cnt& = 1: If CountColumn& Then cnt& = Abs(Fix(Val(ro.Cells(CountColumn&))))
        If Not ro.EntireRow.Hidden Then CalculateLabelsCount = CalculateLabelsCount + cnt&
    Next
End Function

Function ReplaceFieldInRange(ByRef DestRange As Range, ByVal ReplaceField, _
                             ByVal SourceRow As Range, ByVal Index As Long)
    On Error Resume Next: Err.Clear
    Dim rf As String, txt, IsEAN13 As Boolean, IsCode128 As Boolean, prefix$         ' rf - ключ поля без скобок, txt - замена для этого поля
    rf = Replace(Replace(ReplaceField, "}", ""), "{", "")
    Dim sh As Worksheet: Set sh = SourceRow.Worksheet
    IsEAN13 = False: If rf Like "*(ean13)*" Then IsEAN13 = True: rf = Replace(rf, "(ean13)", "")
    IsCode128 = False: If rf Like "*(code128)*" Then IsCode128 = True: rf = Replace(rf, "(code128)", "")

    Select Case True
        Case rf Like String(Len(rf), "#")        ' только цифры - ссылка на столбец
            txt = SourceRow.Cells(Val(rf))
        Case rf Like "=[A-z]*#"        ' ссылка на постоянную ячейку
            Err.Clear: txt = sh.Range(Mid(rf, 2)).Cells(1)
            If Err.Number = 1004 Then txt = "{incorrect cell or range name: " & rf & "}"
        Case rf Like "=*"        ' ссылка на именованный диапазон
            Err.Clear: txt = sh.Range(Mid(rf, 2)).Value
            If Err.Number = 1004 Then txt = "{named range not found: " & rf & "}"
        Case rf = "now", rf = "date": txt = Now
        Case rf = "index": txt = Index
        Case Else: txt = "{unknown reference: " & rf & "}"
    End Select

    If IsEAN13 And (InStr(1, txt, ": ") = 0) Then    ' преобразуем в код формата EAN13
        prefix$ = SETT.GetText("TextBox_EAN13_Prefix")
        txt = Trim(txt)
        If Len(txt) < 13 Then
            prefix$ = prefix$ & String(12 - Len(txt) - Len(prefix$), "0")
            txt = prefix$ & txt
            'txt = add_check_digit(txt)
        End If
        txt = ean13(txt)
    End If

    If IsCode128 And (InStr(1, txt, ": ") = 0) Then    ' преобразуем в код формата Code128
        txt = Code128(txt)
    End If

    ' If index = 1 Then Debug.Print "replace «" & ReplaceField & "» with «" & txt & "»"
    DestRange.Replace ReplaceField, txt, xlPart, , False, , False, False
    'If Err Then Debug.Print Err.Number, Err.Description
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
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FindAll
    ' This searches the range specified by SearchRange and returns a Range object
    ' that contains all the cells in which FindWhat was found. The search parameters to
    ' this function have the same meaning and effect as they do with the
    ' Range.Find method. If the value was not found, the function return Nothing. If
    ' BeginsWith is not an empty string, only those cells that begin with BeginWith
    ' are included in the result. If EndsWith is not an empty string, only those cells
    ' that end with EndsWith are included in the result. Note that if a cell contains
    ' a single word that matches either BeginsWith or EndsWith, it is included in the
    ' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
    ' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
    ' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
    ' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
    ' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
    ' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
    ' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    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

    ' this loop in Areas is to find the last cell of all the areas. That is, the cell whose row
    ' and column are greater than or equal to any cell in any Area.
    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)
…