Malicious Office (OOXML) / .XLSX — malware analysis report

Attribute VB_Name = "ЭтаКнига"
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
Option Explicit
Private Sub Workbook_Open()
    If Application.Calculation <> xlCalculationManual Then
        Application.Calculation = xlCalculationManual
    End If
    If Application.CalculateBeforeSave <> False Then
        Application.CalculateBeforeSave = False
    End If
    WbOrgParamsInitialize
End Sub
Private Sub Workbook_Activate()
    WbOrgParamsInitialize
    SetProtectOption ThisWorkbook.ActiveSheet
    If Not InitMenu() Then
        Exit Sub
    End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    WbOrgParamsInitialize
    SetProtectOption Sh
End Sub
Private Sub SetProtectOption(ByVal Ws As Worksheet)
    'Защита листа не включена
    If Not Ws.ProtectContents Then Exit Sub
    'Нужные опции защиты листа уже установлены
    If Ws.ProtectionMode Then Exit Sub
    'Устанавливаем необходимые опции защиты листа
    Dim bSaved As Boolean
    On Error GoTo SetProtectOption1
    bSaved = Ws.Parent.Saved
    Ws.EnableOutlining = True
    Ws.Protect _
        DrawingObjects:=Ws.ProtectDrawingObjects, _
        Contents:=True, _
        Scenarios:=Ws.ProtectScenarios, _
        UserInterfaceOnly:=True, _
        AllowFormattingCells:=Ws.Protection.AllowFormattingCells, _
        AllowFormattingColumns:=Ws.Protection.AllowFormattingColumns, _
        AllowFormattingRows:=Ws.Protection.AllowFormattingRows, _
        AllowInsertingColumns:=Ws.Protection.AllowInsertingColumns, _
        AllowInsertingRows:=Ws.Protection.AllowInsertingRows, _
        AllowInsertingHyperlinks:=Ws.Protection.AllowInsertingHyperlinks, _
        AllowDeletingColumns:=Ws.Protection.AllowDeletingColumns, _
        AllowDeletingRows:=Ws.Protection.AllowDeletingRows, _
        AllowSorting:=Ws.Protection.AllowSorting, _
        AllowFiltering:=Ws.Protection.AllowFiltering, _
        AllowUsingPivotTables:=Ws.Protection.AllowUsingPivotTables
    Ws.Parent.Saved = bSaved
    Exit Sub
SetProtectOption1:
    MsgBox Err.Description, vbCritical
End Sub



Attribute VB_Name = "Sheet1"
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 = "Лист9"
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 = "Лист8"
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 = "Sheet2"
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 = "Лист7"
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 = "Лист4"
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 = "Лист5"
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 = "Лист6"
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 = "Procedures"
Option Explicit
Public Function MainRunProcedure(DbConn As ADODB.Connection, Ws As Worksheet, ProcId As Integer, ProcName As String, ProcGuid As String, ProcCategory As Integer, ProcVersion As Integer) As Boolean
    Dim bRet As Boolean
    On Error GoTo MainRunProcedureError
    If Not bOrgParamWorkbookOpened Then
        WbOrgParamsInitialize
    End If
    Select Case ProcGuid
        Case "XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX"
            'Пример запуска процедуры построения отчета MyReport()
            bRet = MyReport(DbConn, Ws, ProcName, ProcVersion)
        Case Else
            Select Case ProcCategory
                Case ciProcCat_Report
                    MsgErr SM000014, ProcName, ProcGuid 'Не найдена процедура построения отчета.
                Case ciProcCat_Calculate
                    MsgErr SM000015, ProcName, ProcGuid 'Не найдена процедура расчета данных.
                Case ciProcCat_DataPrepare
                    MsgErr SM000016, ProcName, ProcGuid 'Не найдена процедура подготовки данных.
                Case ciProcCat_DataImport
                    MsgErr SM000017, ProcName, ProcGuid 'Не найдена процедура импорта данных.
                Case ciProcCat_DataExport
                    MsgErr SM000018, ProcName, ProcGuid 'Не найдена процедура экспорта данных.
                Case ciProcCat_DataProcessing
                    MsgErr SM000019, ProcName, ProcGuid 'Не найдена процедура обработки данных.
                Case Else
                    MsgErr SM000019, ProcName, ProcGuid 'Не найдена процедура обработки данных.
            End Select
    End Select
    MainRunProcedure = bRet
    Exit Function
MainRunProcedureError:
    MsgErr Err.Description
End Function
Private Function MyReport(DbConn As ADODB.Connection, Ws As Worksheet, ProcName As String, ProcVersion As Integer) As Boolean
    MyReport = True
End Function


Attribute VB_Name = "Лист1"
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 = "Library"
Option Explicit
Public Const csCoreBookName = "EraTaxRegGen.xlsm"
Public Const csOrgParamsBookName = "EraTaxOrgParams.xlsm"
Public Const csRepTemplateBookName = "EraTaxRegGen.xltm"
'
Public Const csGeneralNumberFormat = "General" 'Общий
Public Const csDateNumberFormat = "m/d/yyyy"   'Дата
Public Const csTextNumberFormat = "@"          'Текстовый
'
Public Const ciProcCat_Report = 1
Public Const ciProcCat_Calculate = 2
Public Const ciProcCat_DataPrepare = 3
Public Const ciProcCat_DataImport = 4
Public Const ciProcCat_DataExport = 5
Public Const ciProcCat_DataProcessing = 6
'
#If Win64 Then
    Private Declare PtrSafe Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
#Else
    Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
#End If
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
'
Public Enum EnumEntryMode
    EMValue = 0   'Записывать данные как значение
    EMFormula = 1 'Записывать данные как формулу
End Enum
'
Public Const SM000001 = "Нет активного соединения."
Public Const SM000002 = "Не найден параметр ""[1]""."
Public Const SM000003 = "Не найдена ссылка на таблицу для параметра ""[1]""."
Public Const SM000004 = "Некорректное значение ""[2]"" параметра ""[1]""."
Public Const SM000006 = "Не найден лист настроек отчета ""[1]""."
Public Const SM000007 = "Некорректное значение ""[2]"" параметра ""[1]"". Допустимые значения: [3]."
Public Const SM000008 = "Построение отчета завершилось с ошибками."
Public Const SM000009 = "Импорт завершился с ошибками."
Public Const SM000010 = "Обработка завершилась с ошибками."
Public Const SM000011 = "Соединение с базой данных не открыто."
Public Const SM000012 = "Параметры листа отчета не соответствуют запускаемой процедуре."
Public Const SM000014 = "Не найдена процедура построения отчета ""[1]"". Идентификатор: ""[2]""."
Public Const SM000015 = "Не найдена процедура расчета данных ""[1]"". Идентификатор: ""[2]""."
Public Const SM000016 = "Не найдена процедура подготовки данных ""[1]"". Идентификатор: ""[2]""."
Public Const SM000017 = "Не найдена процедура импорта данных ""[1]"". Идентификатор: ""[2]""."
Public Const SM000018 = "Не найдена процедура экспорта данных ""[1]"". Идентификатор: ""[2]""."
Public Const SM000019 = "Не найдена процедура обработки данных ""[1]"". Идентификатор: ""[2]""."
'
Public Function CreateGuid() As String
    Dim udtGUID As GUID
    If CoCreateGuid(udtGUID) = 0 Then
        CreateGuid = _
            String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & "-" & _
            String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & "-" & _
            String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & "-" & _
            IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
            IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & "-" & _
            IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
            IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
            IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
            IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
            IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
            IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
    End If
End Function
Public Function WorkbookExists(ByVal WbName As String) As Boolean
    Dim Wb As Workbook
    Dim n As Integer
    n = InStr(StrReverse(WbName), Application.PathSeparator)
    If n > 0 Then
        WbName = Right(WbName, n - 1)
    End If
    For Each Wb In Workbooks
        If LCase(Wb.Name) = LCase(WbName) Then
            WorkbookExists = True
            Exit Function
        End If
    Next
End Function
Public Function GetWorkbookObject(ByVal WbName As String) As Workbook
    Dim Wb As Workbook
    Dim n As Integer
    n = InStr(StrReverse(WbName), Application.PathSeparator)
    If n > 0 Then
        WbName = Right(WbName, n - 1)
    End If
    For Each Wb In Workbooks
        If LCase(Wb.Name) = LCase(WbName) Then
            Set GetWorkbookObject = Wb
            Exit Function
        End If
    Next
End Function
Public Function WorksheetExists(Wb As Workbook, WsName As String) As Boolean
    Dim Ws As Worksheet
    For Each Ws In Wb.Worksheets
        If LCase(Ws.Name) = LCase(WsName) Then
            WorksheetExists = True
            Exit Function
        End If
    Next
End Function
Public Function GetWorksheetObject(Wb As Workbook, WsName As String) As Worksheet
    Dim Ws As Worksheet
    For Each Ws In Wb.Worksheets
        If LCase(Ws.Name) = LCase(WsName) Then
            Set GetWorksheetObject = Ws
            Exit Function
        End If
    Next
End Function
Public Function GetWBListObject(Wb As Workbook, ListObjectName As String) As ListObject
    Dim Ws As Worksheet
    Dim ListObj As ListObject
    If ListObjectName = "" Then
        Exit Function
    End If
    For Each Ws In Wb.Worksheets
        For Each ListObj In Ws.ListObjects
            If LCase(ListObj.Name) = LCase(ListObjectName) Then
                Set GetWBListObject = ListObj
                Exit Function
            End If
        Next
    Next
End Function
Public Function GetWSListObject(Ws As Worksheet, ListObjectName As String) As ListObject
    Dim ListObj As ListObject
    If ListObjectName = "" Then
        Exit Function
    End If
    For Each ListObj In Ws.ListObjects
        If LCase(ListObj.Name) = LCase(ListObjectName) Then
            Set GetWSListObject = ListObj
            Exit Function
        End If
    Next
End Function
Public Function GetWSRange(Ws As Worksheet, RangeName As String) As Range
    Dim R As Range
    On Error Resume Next
    Set R = Ws.Range(RangeName)
    If Not R Is Nothing Then
        Set GetWSRange = R
    End If
End Function
Public Function GetWSRangeRange(Ws As Worksheet, RangeName As String, Optional ByVal Required As Boolean = True) As Range
    Dim R As Range
    On Error GoTo GetWSRangeRangeError
    Set R = GetWSRange(Ws, RangeName)
    If R Is Nothing Then
        If Required Then
            MsgErr SM000002, RangeName
        End If
        Exit Function
    End If
    Set GetWSRangeRange = R
    Exit Function
GetWSRangeRangeError:
    MsgErr Err.Description
End Function
Public Function GetWSRangeValue(Ws As Worksheet, RangeName As String, ByRef Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As Boolean
    Dim R As Range
    On Error GoTo GetWSRangeValueError
    Set R = GetWSRange(Ws, RangeName)
    If R Is Nothing Then
        If Required Then
            MsgErr SM000002, RangeName
        End If
        Exit Function
    End If
    If R.Cells(1, nCol).HasFormula Then
        R.Cells(1, nCol).Calculate
    End If
    Value = R.Cells(1, nCol).Value
    GetWSRangeValue = True
    Exit Function
GetWSRangeValueError:
    MsgErr Err.Description
End Function
Public Function SetWSRangeValue(Ws As Worksheet, RangeName As String, Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As Boolean
    Dim R As Range
    On Error GoTo SetWSRangeValueError
    Set R = GetWSRange(Ws, RangeName)
    If R Is Nothing Then
        If Required Then
            MsgErr SM000002, RangeName
        End If
        Exit Function
    End If
    R.Cells(1, nCol).Value = Value
    SetWSRangeValue = True
    Exit Function
SetWSRangeValueError:
    MsgErr Err.Description
End Function
Public Function GetRangeValue(R As Range, Optional ByVal nCol As Integer = 2) As Variant
    On Error GoTo GetRangeValueError
    If R.Cells(1, nCol).HasFormula Then
        R.Cells(1, nCol).Calculate
    End If
    GetRangeValue = R.Cells(1, nCol).Value
    Exit Function
GetRangeValueError:
    MsgErr Err.Description
End Function
Public Function SetRangeValue(R As Range, Value As Variant, Optional ByVal nCol As Integer = 2) As Variant
    On Error GoTo SetRangeValueError
    R.Cells(1, nCol).Value = Value
    SetRangeValue = Value
    Exit Function
SetRangeValueError:
    MsgErr Err.Description
End Function
Public Function GetFieldRange(WSRange As Range, Optional ByVal nCol As Integer = 2) As Range
    Dim Address As String
    Dim R As Range
    On Error GoTo GetFieldRangeError
    If WSRange.Cells(1, nCol).HasFormula Then
        Address = WSRange.Cells(1, nCol).Formula
        If Not Address Like "*!*" Then
            Address = Replace(Address, " ", "")
            Address = Replace(Address, "=""""&", "")
            Address = Replace(Address, "=", "")
            Set R = GetWSRange(WSRange.Parent, Address)
            If Not R Is Nothing Then
                Set GetFieldRange = R
                Exit Function
            End If
        End If
    End If
    Exit Function
GetFieldRangeError:
    MsgErr Err.Description
End Function
Public Function SetFieldValue(FieldRange As Range, Value As Variant, Optional ByVal EntryMode As EnumEntryMode = EMValue) As Boolean
    On Error GoTo SetFieldValueError
    If Not FieldRange.DisplayFormat.Locked Then
        If FieldRange.DisplayFormat.NumberFormat = "@" Then
            FieldRange.Cells(1, 1).Value = Value
        Else
            If EntryMode = EMValue Then
                FieldRange.Cells(1, 1).Value = Value
            Else 'EM_Formula
                If VarType(Value) = vbString Then
                    FieldRange.Cells(1, 1).Formula = "=""" & Replace(Value, """", """""") & """"
                ElseIf VarType(Value) = vbDate Then
                    FieldRange.Cells(1, 1).Formula = "=" & CDbl(Value)
                Else
                    FieldRange.Cells(1, 1).Formula = "=" & Value
                End If
            End If
        End If
        SetFieldValue = True
    End If
    Exit Function
SetFieldValueError:
    MsgErr Err.Description
End Function
Public Function GetRangeParamValue(R As Range, ParamName As String, ByRef Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As Boolean
    Dim i As Long
    Dim j As Long
    On Error GoTo GetRangeParamValueError
    i = 2
    Do While R.Cells(i, 1).Value <> ""
        If R.Cells(i, 1).Value = ParamName Then
            If (VarType(Value) And vbArray) = vbArray Then
                j = 1
                ReDim Value(0)
                Do While R.Cells(i, 1).Value = ParamName
                    ReDim Preserve Value(j)
                    If R.Cells(i, nCol).HasFormula Then
                        R.Cells(i, nCol).Calculate
                    End If
                    Value(j) = R.Cells(i, nCol).Value
                    i = i + 1
                    j = j + 1
                Loop
            Else
                If R.Cells(i, nCol).HasFormula Then
                    R.Cells(i, nCol).Calculate
                End If
                Value = R.Cells(i, nCol).Value
            End If
            GetRangeParamValue = True
            Exit Do
        End If
        i = i + 1
    Loop
    If Not GetRangeParamValue Then
        If Required Then
            MsgErr SM000002, ParamName
        End If
        Exit Function
    End If
    Exit Function
GetRangeParamValueError:
    MsgErr Err.Description
End Function
Public Function GetRangeParamId(R As Range, ParamName As String, ByRef Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nMaxCol As Integer = 2) As Boolean
    Dim i As Long
    Dim j As Long
    Dim Ws As Worksheet
    Dim RCalc As Range
    On Error GoTo GetRangeParamIdError
    i = 2
    Do While R.Cells(i, 1).Value <> ""
        If R.Cells(i, 1).Value = ParamName Then
            Set RCalc = R.Cells(i, 1)
            If (VarType(Value) And vbArray) = vbArray Then
                j = 1
                ReDim Value(0)
                Do While R.Cells(i, 1).Value = ParamName
                    ReDim Preserve Value(j)
                    Value(j) = i
                    i = i + 1
                    j = j + 1
                Loop
            Else
                Value = i
                i = i + 1
            End If
            Set Ws = R.Parent
            Set RCalc = Ws.Range(RCalc.Cells(1, 1), R.Cells(i - 1, nMaxCol))
            'If Ws.Name = ActiveWorkbook.ActiveSheet.Name Then
            '    RCalc.Select
            'End If
            RCalc.Calculate
            GetRangeParamId = True
            Exit Do
        End If
        i = i + 1
    Loop
    If Not GetRangeParamId Then
        If Required Then
            MsgErr SM000002, ParamName
        End If
        Exit Function
    End If
    Exit Function
GetRangeParamIdError:
    MsgErr Err.Description
End Function
Public Function SetRangeParamValue(R As Range, ParamName As String, Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As Boolean
    Dim i As Long
    Dim j As Long
    On Error GoTo SetRangeParamValueError
    i = 2
    Do While R.Cells(i, 1).Value <> ""
        If R.Cells(i, 1).Value = ParamName Then
            If (VarType(Value) And vbArray) = vbArray Then
                j = 1
                Do While R.Cells(i, 1).Value = ParamName And j <= UBound(Value)
                    R.Cells(i, nCol).Value = Value(j)
                    i = i + 1
                    j = j + 1
                Loop
            Else
                R.Cells(i, nCol).Value = Value
            End If
            SetRangeParamValue = True
            Exit Do
        End If
        i = i + 1
    Loop
    If Not SetRangeParamValue Then
        If Required Then
            MsgErr SM000002, ParamName
        End If
        Exit Function
    End If
    Exit Function
SetRangeParamValueError:
    MsgErr Err.Description
End Function
Public Function GetWSRangeListObject(Ws As Worksheet, RangeName As String, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As ListObject
    Dim ListObj As ListObject
    Dim R As Range
    On Error GoTo GetWSRangeListObjectError
    Set R = GetWSRange(Ws, RangeName)
    If R Is Nothing Then
        If Required Then
            MsgErr SM000002, RangeName
        End If
        Exit Function
    End If
    Set ListObj = GetWBListObject(Ws.Parent, ParseListObjName(R.Cells(1, nCol)))
    If ListObj Is Nothing Then
        If Required Then
            MsgErr SM000003, RangeName
        End If
        Exit Function
    End If
    Set GetWSRangeListObject = ListObj
    Exit Function
GetWSRangeListObjectError:
    MsgErr Err.Description
End Function
Public Function GetRangeListObject(R As Range, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As ListObject
    Dim ListObj As ListObject
    On Error GoTo GetRangeListObjectError
    Set ListObj = GetWBListObject(R.Parent.Parent, ParseListObjName(R.Cells(1, nCol)))
    If ListObj Is Nothing Then
        If Required Then
            MsgErr SM000003, R.Cells(1, 1)
        End If
        Exit Function
    End If
    Set GetRangeListObject = ListObj
    Exit Function
GetRangeListObjectError:
    MsgErr Err.Description
End Function
Public Function GetRangeParamListObject(R As Range, ParamName As String, ByRef Value As Variant, Optional ByVal Required As Boolean = True, Optional ByVal nCol As Integer = 2) As Boolean
    Dim i As Long
    Dim j As Long
    On Error GoTo GetRangeParamListObjectError
    i = 2
    Do While R.Cells(i, 1).Value <> ""
        If R.Cells(i, 1).Value = ParamName Then
            If (VarType(Value) And vbArray) = vbArray Then
                j = 1
                ReDim Value(0)
                Do While R.Cells(i, 1).Value = ParamName
                    ReDim Preserve Value(j)
                    Set Value(j) = GetWBListObject(R.Parent.Parent, ParseListObjName(R.Cells(i, nCol)))
                    i = i + 1
                    j = j + 1
                Loop
            Else
                Set Value = GetWBListObject(R.Parent.Parent, ParseListObjName(R.Cells(i, nCol)))
            End If
            GetRangeParamListObject = True
            Exit Do
        End If
        i = i + 1
    Loop
    If Not GetRangeParamListObject Then
        If Required Then
            MsgErr SM000002, ParamName
        End If
        Exit Function
    End If
    Exit Function
GetRangeParamListObjectError:
    MsgErr Err.Description
End Function
Public Function GetListObjectColumnId(ListObj As ListObject, ColumnName As String) As Long
    Dim oCol As ListColumn
    On Error GoTo GetListObjectColumnId1
    For Each oCol In ListObj.ListColumns
        If oCol.Name = ColumnName Then 'Точное совпадение
            GetListObjectColumnId = oCol.Index
            Exit Function
        End If
    Next
    Exit Function
GetListObjectColumnId1:
    MsgErr Err.Description
End Function
Public Function ParseListObjName(R As Range) As String
    Dim n As Integer
    If Not R.HasFormula Then
        Exit Function
    End If
    n = InStr(R.Formula, "[")
    If n > 0 Then
        ParseListObjName = Mid(R.Formula, 2, n - 2)
    End If
End Function
Public Function VBComponentsExists(Wb As Workbook, VBCompName As String) As Boolean
    Dim i As Integer
    For i = 1 To Wb.VBProject.VBComponents.Count
        If LCase(Wb.VBProject.VBComponents(i).Name) = LCase(VBCompName) Then
            VBComponentsExists = True
            Exit For
        End If
    Next
End Function
Public Function GetReferenceIndex(Wb As Workbook, RefName As String) As Integer
    Dim i As Integer
    For i = 1 To Wb.VBProject.References.Count
        If LCase(Left(Wb.VBProject.References.Item(i).Description, Len(RefName))) = LCase(RefName) Then
            GetReferenceIndex = i
            Exit For
        End If
    Next
End Function
Public Function AppNavigate(ByVal sFile As String) As Boolean
    Dim oApp As Object
    On Error GoTo AppNavigateError
    Set oApp = CreateObject("WScript.Shell")
    If Dir(sFile) <> "" Then
        sFile = """" & sFile & """" 'Путь и имя файла могут содержать пробелы
        oApp.Run (sFile) 'Аналогично двойному щелчку мыши на файле
        AppNavigate = True
    End If
    Exit Function
AppNavigateError:
    MsgErr Err.Description
End Function
Public Function SetAppStatusBarMsg(Msg As String)
    On Error Resume Next
    Application.StatusBar = Msg
End Function
Public Sub MsgErr(ByVal sMsg As String, ParamArray Args())
    Dim vArg As Variant
    Dim i As Integer
    i = 0
    For Each vArg In Args
        i = i + 1
        sMsg = Replace(sMsg, "[" & i & "]", vArg)
    Next
    MsgBox sMsg, vbCritical
End Sub
Public Function MsgDlg(ByVal sMsg As String, BoxStyle As VbMsgBoxStyle, ParamArray Args()) As VbMsgBoxResult
    Dim vArg As Variant
    Dim i As Integer
    i = 0
    For Each vArg In Args
        i = i + 1
        sMsg = Replace(sMsg, "[" & i & "]", vArg)
    Next
    MsgDlg = MsgBox(sMsg, BoxStyle)
End Function
Public Function ArrayBubbleSort(aArray As Variant, Optional ByVal LeftBound As Integer = 1)
    Dim Temp As Variant
    Dim i As Integer
    Dim NoExchanges As Integer
    On Error GoTo ArrayBubbleSort1
    If LeftBound < LBound(aArray) Then
        LeftBound = LBound(aArray)
    End If
    Do
        NoExchanges = True
        For i = LeftBound To UBound(aArray) - 1
            If aArray(i) > aArray(i + 1) Then
                NoExchanges = False
                Temp = aArray(i)
                aArray(i) = aArray(i + 1)
                aArray(i + 1) = Temp
            End If
        Next i
    Loop While Not (NoExchanges)
    Exit Function
ArrayBubbleSort1:
    MsgErr Err.Description
End Function
Public Function SaveTextToFile(ByRef Text As String, ByVal Filename As String, Optional ByVal Encoding As String) As Boolean
    On Error GoTo SaveTextToFile1
    If Trim(Encoding) = "" Then Encoding = "windows-1251"
    With CreateObject("ADODB.Stream")
        .Type = adTypeText
        .Charset = Encoding
        .Open
        .WriteText Text
        .SaveToFile Filename, adSaveCreateOverWrite 'Сохраняем файл в заданной кодировке
        .Close
    End With
    SaveTextToFile = True
    Exit Function
SaveTextToFile1:
    MsgErr Err.Description
End Function
Public Function LoadTextFromTextFile(ByVal Filename As String, Optional ByVal Encoding As String) As String
    On Error GoTo LoadTextFromTextFile1
    If Trim(Encoding) = "" Then Encoding = "windows-1251"
    With CreateObject("ADODB.Stream")
        .Type = adTypeText
        .Charset = Encoding
        .Open
        .LoadFromFile Filename 'Загружаем данные из файла
        LoadTextFromTextFile = .ReadText(adReadAll) 'Считываем текст файла
        .Close
    End With
    Exit Function
LoadTextFromTextFile1:
    MsgErr Err.Description
End Function

Attribute VB_Name = "Functions"
Option Explicit
Public Const csMainMenuName = "Налоговая отчетность"
Public Const csProcessingMenuName = "Обработка"
'
Private Const csRegisterName = "ERA Financials Tax Registry Generator"
'
Private Const csPublic_Sys_Sys_Params_SheetName = "Public_Sys_Sys_Params"
Private Const csPublic_Sys_App_Params_SheetName = "Public_Sys_App_Params"
Private Const csPublic_Usr_App_Params_SheetName = "Public_Usr_App_Params"
Private Const csPublic_Sys_Db_Params_SheetName = "Public_Sys_Db_Params"
Private Const csPublic_Usr_Db_Params_SheetName = "Public_Usr_Db_Params"
'
Private Const csPrivate_Sys_App_Params_SheetName = "Private_Sys_App_Params"
Private Const csPrivate_Usr_App_Params_SheetName = "Private_Usr_App_Params"
Private Const csPrivate_Sys_Sys_Params_SheetName = "Private_Sys_Sys_Params"
Private Const csPrivate_Sys_Rep_Params_SheetName = "Private_Sys_Rep_Params"
Private Const csPrivate_Usr_Rep_Params_SheetName = "Private_Usr_Rep_Params"
Private Const csPrivate_Sys_Rep_Menu_SheetName = "Private_Sys_Rep_Menu"
'
Private Const ciPublic_Sys_Sys_Params_Group = 110
Private Const ciPublic_Sys_App_Params_Group = 120
Private Const ciPublic_Usr_App_Params_Group = 130
'
Private Const ciPrivate_Sys_Sys_Params_Group = 210
Private Const ciPrivate_Sys_Rep_Params_Group = 220
Private Const ciPrivate_Usr_Rep_Params_Group = 230
'
Private Const ciLocDefIdModule = 1
Private Const ciLocDefIdLogin = 2
'
Private Const ciLocParamsApp = 1  'Модуль
Private Const ciLocParamsDb = 2   'База
Private Const ciLocParamsFile = 3 'Отчет
Private Const ciLocParamsReg = 4  'Реестр
'
Private Const ciConnTimeout = 15
Private Const ciCommandTimeout = 36000
'
Private wOrgParamWorkbook As Workbook
Public bOrgParamWorkbookOpened As Boolean
'
Private Conn As ADODB.Connection
Private CalcStep As Integer
Public Function WbOrgParamsInitialize() As Boolean
    WbOrgParamsInitialize = bOrgParamWorkbookOpened
    If Not bOrgParamWorkbookOpened Then
        WbOrgParamsInitialize = OpenOrgParamsWorkbook(csOrgParamsBookName)
    End If
End Function
Private Function OpenOrgParamsWorkbook(ByVal WorkbookName As String) As Boolean
    Dim Wb As Workbook
    Set wOrgParamWorkbook = Nothing
    bOrgParamWorkbookOpened = False
    For Each Wb In Workbooks
        If LCase(Wb.Name) = LCase(WorkbookName) Then
            Set wOrgParamWorkbook = Wb
            bOrgParamWorkbookOpened = True
            Exit For
        End If
    Next
    OpenOrgParamsWorkbook = bOrgParamWorkbookOpened
End Function
Public Function InitMenu() As Boolean
    Dim oMainMenu As Menu
    Dim oMenu As Menu
    Dim oItem As MenuItem
    Dim oMenuItem As Object
    Dim Wb As Workbook
    Dim R As Range
    Dim i As Integer
    On Error GoTo InitMenu1
    WbOrgParamsInitialize
    InitMenu = True
    For Each oMainMenu In ActiveMenuBar.Menus
        If oMainMenu.Caption = csMainMenuName Then
            Exit For
        End If
    Next
    If oMainMenu Is Nothing Then
        Exit Function
    End If
    Set Wb = GetWorkbookObject(csCoreBookName)
    If Not Wb Is Nothing Then
        If Application.Run("'" & Wb.FullName & "'!CheckVersionWorkbookTaxReport", ThisWorkbook) Then
            Set R = ThisWorkbook.Worksheets(csPrivate_Sys_Rep_Menu_SheetName).Cells(2, 1)
            i = 1
            Do While Not IsEmpty(R.Cells(i, 1).Value)
                If R.Cells(i, 2).Value = 1 Then
                    For Each oMenuItem In oMainMenu.MenuItems
                        If oMenuItem.Caption = R.Cells(i, 4).Value Then
                            If oMenuItem.Caption = csProcessingMenuName Then
                                For Each oItem In oMenuItem.MenuItems
                                    oItem.Delete
                                Next
                            End If
                            oMenuItem.Enabled = IIf(R.Cells(i, 3).Value = 1, True, False)
                            Exit For
                        End If
                    Next
                End If
                i = i + 1
            Loop
            Set oMenu = oMainMenu.MenuItems(csProcessingMenuName)
            i = 1
            Do While Not IsEmpty(R.Cells(i, 1).Value)
                If R.Cells(i, 2).Value = 2 And R.Cells(i, 3).Value = 1 Then
                    Set oItem = oMenu.MenuItems.Add(R.Cells(i, 4).Value, OnAction:="'" & Wb.FullName & "'!ExecuteDataProcessing" & Right("00" & R.Cells(i, 1).Value, 2))
                End If
                i = i + 1
            Loop
        Else
            InitDefaultMenu oMainMenu
        End If
    Else
        InitDefaultMenu oMainMenu
    End If
    Exit Function
InitMenu1:
    MsgBox Err.Description, vbCritical
    InitMenu = False
End Function
Private Sub InitDefaultMenu(oMainMenu As Menu)
    Dim oMenuItem As Object
    Dim oItem As MenuItem
    For Each oMenuItem In oMainMenu.MenuItems
        If oMenuItem.Caption <> "-" Then
            If oMenuItem.Caption = csProcessingMenuName Then
                For Each oItem In oMenuItem.MenuItems
                    oItem.Delete
                Next
                oMenuItem.Enabled = False
            Else
                oMenuItem.Enabled = True
            End If
        End If
    Next
End Sub
Public Function DateJul(d As Date) As Long
  DateJul = CLng(d) + 693594
End Function
Public Function RunRecalculate(DbConn As ADODB.Connection, WsRep As Worksheet, Optional WsRepRange As Range) As Boolean
    Dim oWs As Worksheet
    Dim Ws As Worksheet
    Dim sCmd As String
    On Error GoTo RunRecalculateError
    If DbConn Is Nothing Then
        MsgErr SM000001
        Exit Function
    End If
    If DbConn.State <> adStateOpen Then
        MsgErr SM000011
        Exit Function
    End If
    If Not bOrgParamWorkbookOpened Then
        WbOrgParamsInitialize
    End If
    Set Conn = DbConn
    Set Ws = ThisWorkbook.Worksheets(csPrivate_Sys_Sys_Params_SheetName)
    'Создание временной таблицы
    Conn.Execute (Ws.Cells(9, 2).Value) 'PTG_TMP_CREATE
    'Заполнение временной таблицы
    CalcStep = 1
    If Not WsRepRange Is Nothing Then
        WsRepRange.Calculate
    Else
        WsRep.Calculate
    End If
    CalcStep = 0
    'Запуск процедуры
    sCmd = Ws.Cells(11, 2).Value 'PTG_TMP_EXEC
    sCmd = Replace(sCmd, "[1]", (GetParamValue(28, 1, ciPublic_Sys_App_Params_Group, ciLocDefIdModule)))           '@Posted
    sCmd = Replace(sCmd, "[2]", (GetParamValue(29, 1, ciPublic_Sys_App_Params_Group, ciLocDefIdModule) + 1) Mod 2) '@Unposted
    sCmd = Replace(sCmd, "[3]", (GetParamValue(30, 1, ciPublic_Sys_App_Params_Group, ciLocDefIdModule)))           '@Mode_UseBal
    Conn.Execute (sCmd)
    'Получение резульнатов
    CalcStep = 2
    If Not WsRepRange Is Nothing Then
        WsRepRange.Calculate
    Else
        WsRep.Calculate
    End If
    CalcStep = 0
    'Удаление временной таблицы, закрытие соединения
    Conn.Execute (Ws.Cells(13, 2).Value) 'PTG_TMP_DROP
    Set Conn = Nothing
    RunRecalculate = True
    Exit Function
RunRecalculateError:
    If Conn.Errors.Count > 0 Then
        Dim e As ADODB.Error
        For Each e In Conn.Errors
            MsgBox e.Description, vbCritical
        Next
    Else
        MsgBox Err.Description, vbCritical
    End If
    Set Conn = Nothing
End Function
Private Function GetParamValue(Row As Long, Col As Long, Group As Integer, LocDefId As Integer) As Variant
    Dim iLocParams As Integer
    Select Case Group
        Case ciPublic_Sys_Sys_Params_Group
            GetParamValue = wOrgParamWorkbook.Worksheets(csPublic_Sys_Sys_Params_SheetName).Cells(Row, Col + 1).Value
        Case ciPublic_Sys_App_Params_Group
            If LocDefId = ciLocDefIdModule Then '1-Параметры модуля
                iLocParams = wOrgParamWorkbook.Worksheets(csPublic_Sys_Sys_Params_SheetName).Cells(4, 2).Value
            Else '2-Параметры соединения
                iLocParams = wOrgParamWorkbook.Worksheets(csPublic_Sys_Sys_Params_SheetName).Cells(5, 2).Value
            End If
            If wOrgParamWorkbook.Worksheets(csPublic_Sys_App_Params_SheetName).Cells(Row, Col + 2).Value <> "" Then
                iLocParams = wOrgParamWorkbook.Worksheets(csPublic_Sys_App_Params_SheetName).Cells(Row, Col + 2).Value
            End If
            If ThisWorkbook.Worksheets(csPrivate_Sys_App_Params_SheetName).Cells(Row, Col + 2).Value <> "" Then
                iLocParams = ThisWorkbook.Worksheets(csPrivate_Sys_App_Params_SheetName).Cells(Row, Col + 2).Value
            End If
            Select Case iLocParams
                Case ciLocParamsApp
                    GetParamValue = wOrgParamWorkbook.Worksheets(csPublic_Sys_App_Params_SheetName).Cells(Row, Col + 1)
                Case ciLocParamsDb
                    GetParamValue = wOrgParamWorkbook.Worksheets(csPublic_Sys_Db_Params_SheetName).Cells(Row, Col + 1)
                Case ciLocParamsFile
                    GetParamValue = ThisWorkbook.Worksheets(csPrivate_Sys_App_Params_SheetName).Cells(Row, Col + 1)
                Case ciLocParamsReg
                    GetParamValue = GetLoginParamValue(wOrgParamWorkbook.Worksheets(csPublic_Sys_App_Params_SheetName).Cells(Row, Col).Value)
            End Select
        Case ciPublic_Usr_App_Params_Group
            If LocDefId = ciLocDefIdModule Then '1-Параметры модуля
                iLocParams = wOrgParamWorkbook.Worksheets(csPublic_Sys_Sys_Params_SheetName).Cells(4, 2).Value
            Else '2-Параметры соединения
                iLocParams = wOrgParamWorkbook.Worksheets(csPublic_Sys_Sys_Params_SheetName).Cells(5, 2).Value
            End If
…