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&, sha As Shape
    Application.ScreenUpdating = False
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    pi.StartNewAction 30, 100, "Заполнение этикеток...", " ", " ", LC
    Dim ReplaceFields As Collection, ReplaceField: Set ReplaceFields = RangeFieldNames(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, iter
                Next ReplaceField
                
                ' заполняем надписи / графические объекты
                For Each sha In GetShapesForRange(ra)
                    pi.Line3 = "Заполнение фигуры «" & sha.Name & "» ..."
                    For Each ReplaceField In ShapeFieldNames(sha)
                        ReplaceFieldInShape sha, ReplaceField, ro, i, iter
                    Next ReplaceField
                    
                    pi.Line3 = "Подстановка баркода / картинки в фигуру «" & sha.Name & "» ..."
                    ' если название фигуры начинается с qr или dmx, то подгружаем баркод
                    LoadBarcodeIntoShape sha
                    pi.Line3 = ""
                Next
                
                ' перебираем все ячейки, и скрываем строки или столбцы,
                ' если в ячейках нулевое или пустое значение
                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 ShapeFieldNames(ByRef sha As Shape) As Collection ' список кодов из конкретной фигуры
    On Error Resume Next
    Dim txt$: txt = sha.TextFrame.Characters.Text
    Set ShapeFieldNames = CodesFromTextString(txt)
End Function

Function RangeFieldNames(ByVal ra As Range) As Collection ' список кодов из всех ячеек диапазона и всех фигур
    On Error Resume Next
    Dim txt$, sha As Shape
    txt$ = Replace(Range2TXT(ra), "}", "}" & vbNewLine)
    
    For Each sha In ra.Worksheet.Shapes
        txt$ = txt$ & vbNewLine & sha.TextFrame.Characters.Text
    Next
    
    Set RangeFieldNames = CodesFromTextString(txt)
End Function

Function CodesFromTextString(ByRef txt$) As Collection
    On Error Resume Next
    Dim res, field$, Item
    Set CodesFromTextString = New Collection
    
    With REGEXP
        .Global = True
        .Pattern = "\{[^{}]+\}"
        If .test(txt$) Then
            Set res = .Execute(txt$)
            For Each Item In res
                field = Item.Value
                CodesFromTextString.Add field, CStr(field)
            Next
        End If
    End With
End Function

Function GetShapesForRange(ByRef ra As Range) As Collection
    On Error Resume Next
    Dim sha As Shape, txt$
    Set GetShapesForRange = New Collection
    For Each sha In ra.Worksheet.Shapes
        If Not Intersect(ra, sha.TopLeftCell) Is Nothing Then
            txt = "": txt = sha.TextFrame.Characters.Text
            If Len(txt) > 0 Then GetShapesForRange.Add sha
        End If
    Next sha
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 RenderCode(ByVal rf$, ByRef SourceRow As Range, Optional ByVal Index& = 1, Optional ByVal CopyIndex& = 1) As String
    On Error Resume Next
    Dim txt$
    Select Case True
        Case rf Like String(Len(rf), "#")        ' только цифры - ссылка на столбец
            txt = SourceRow.Cells(Val(rf))
        Case rf Like "=[A-z]*#"        ' ссылка на постоянную ячейку
            Err.Clear: txt = SourceRow.Worksheet.Range(Mid(rf, 2)).Cells(1)
            If Err.Number = 1004 Then txt = "{incorrect cell or range name: " & rf & "}"
        Case rf Like "=*"        ' ссылка на именованный диапазон
            Err.Clear: txt = SourceRow.Worksheet.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 rf = "copy": txt = CopyIndex&
        Case Else: txt = "{unknown reference: " & rf & "}"
    End Select
    RenderCode = txt$
End Function

Function ReplaceFieldInShape(ByRef sha As Shape, ByVal ReplaceField, _
        ByRef SourceRow As Range, ByVal Index&, Optional ByVal CopyIndex& = 1)
    On Error Resume Next: Err.Clear
    Dim rf$, txt, IsEAN13 As Boolean, IsCode128 As Boolean, prefix$         ' rf - ключ поля без скобок, txt - замена для этого поля
    rf = Replace(Replace(ReplaceField, "}", ""), "{", "")
    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)", "")
    
    txt = RenderCode(rf$, SourceRow, Index&, CopyIndex&)
    sha.TextFrame.Characters.Text = Replace(sha.TextFrame.Characters.Text, ReplaceField, txt)
End Function

Function ReplaceFieldInRange(ByRef DestRange As Range, ByVal ReplaceField, _
        ByRef SourceRow As Range, ByVal Index&, Optional ByVal CopyIndex& = 1)
    On Error Resume Next: Err.Clear
    Dim rf$, txt, IsEAN13 As Boolean, IsCode128 As Boolean, prefix$         ' rf - ключ поля без скобок, txt - замена для этого поля
    rf = Replace(Replace(ReplaceField, "}", ""), "{", "")
    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)", "")
    
    txt = RenderCode(rf$, SourceRow, Index&, CopyIndex&)
    
    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, _
…