Malicious Office (OOXML) — 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
'---------------------------------------------------------------------------------------
' Module    : ЭтаКнига
' DateTime  : 19.10.2012 08:04
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   :
'---------------------------------------------------------------------------------------
Dim bAlreadyStart As Boolean
Private Sub Workbook_AddinInstall()
        If bAlreadyStart = False Then
            bAlreadyStart = True
            Application.OnTime Now + TimeValue("00:00:03"), "'" & ThisWorkbook.FullName & " '!CallOnStart"
        End If
End Sub

Private Sub Workbook_AddinUninstall()
        On Error Resume Next
        Application.OnTime dblTicAutoriz, "'" & ThisWorkbook.FullName & " '!KeepAuth", , False
        Me.Save
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
        On Error Resume Next
        Application.OnTime dblTicAutoriz, "'" & ThisWorkbook.FullName & " '!KeepAuth", , False
        Me.Save
End Sub

Private Sub Workbook_Open()
        If bAlreadyStart = False Then
            bAlreadyStart = True
            Application.OnTime Now + TimeValue("00:00:03"), "'" & ThisWorkbook.FullName & " '!CallOnStart"
        End If
End Sub



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
Option Explicit


Attribute VB_Name = "ufGetRentab"
Attribute VB_Base = "0{DD486054-19AC-4583-A61E-C652F634C6F2}{F84F2D69-A14F-404F-B689-B04F9D2CB63F}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Dim aRentab

Private Sub btnCancel_Click()
    Unload Me
End Sub

Private Sub btnOk_Click()
    If Me.MultiPage1.Value < 2 Then
        If CheckFillPage(Me.MultiPage1.Value) Then
            Me.MultiPage1.Value = Me.MultiPage1.Value + 1
            btnOk.Enabled = False
        End If
        If Me.MultiPage1.Value = 2 Then
            btnOk.Caption = "РАССЧИТАТЬ"
        End If
    Else
        If CheckFillPage(2) Then
            Call GetRent
            Unload Me
        End If
    End If
    If Me.MultiPage1.Value = 0 Then
        btnPrev.Enabled = False
    Else
        btnPrev.Enabled = True
    End If
    
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub btnPrev_Click()
    If Me.MultiPage1.Value > 0 Then
        Me.MultiPage1.Value = Me.MultiPage1.Value - 1
    End If
    If Me.MultiPage1.Value = 0 Then
        btnPrev.Enabled = False
    End If
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub cbxActionType1_Change()
    Dim s As String
    s = cbxActionType1.Value
    If s = "" Then s = "*"
    GetList ThisWorkbook.Sheets(sRENTAB_ShName), cbxActionType2, 1, s
    cbxActionType3.Clear

    GetNormatives Me.MultiPage1.Value
    If cbxActionType2.ListCount > 0 Then
        ComboListAutoSize cbxActionType2
    End If
End Sub

Private Sub cbxActionType2_Change()
    Dim s As String
    s = cbxActionType2.Value
    If s = "" Then s = "*"
    GetList ThisWorkbook.Sheets(sRENTAB_ShName), cbxActionType3, 2, s
    GetNormatives Me.MultiPage1.Value
    
    If cbxActionType3.ListCount > 0 Then
        ComboListAutoSize cbxActionType3
    End If
End Sub

Private Sub cbxActionType3_Change()
    GetNormatives Me.MultiPage1.Value
End Sub

Private Sub cbxYear_Change()
    GetNormatives Me.MultiPage1.Value
End Sub

Private Sub tbxKommercialCosts_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxMagreNonTax_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxManagersCosts_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxNorm1_Change()
    tbxrent_n_text = Txt2Num(tbxNorm1.Value, True) * 0.9
    Call init_tbxrent_n(tbxrent_n, tbxrent_n_text)
End Sub

Private Sub tbxNorm2_Change()
    tbxrenta_n_text = Txt2Num(tbxNorm2.Value, True) * 0.9
    Call init_tbxrenta_n(tbxrenta_n, tbxrenta_n_text)
End Sub

Private Sub tbxAverageActivesRent_Change()
    'tbxrenta_r_text = tbxAverageActivesRent.Value
    'Call init_tbxrenta_r(tbxrenta_r, tbxrenta_r_text)
End Sub

Private Sub tbxAverageProductRent_Change()
    'tbxrent_r_text = tbxAverageProductRent.Value
    'Call init_tbxrent_r(tbxrent_r, tbxrent_r_text)
End Sub

'предотвращение ввода букв
'Page3
Private Sub tbxKommercialCosts_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    s = "|46|44|"
    If tbxKommercialCosts.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, tbxKommercialCosts.Value, ".", 1) Or InStr(1, tbxKommercialCosts.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub
Private Sub tbxManagersCosts_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    s = "|46|44|"
    If tbxManagersCosts.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, tbxManagersCosts.Value, ".", 1) Or InStr(1, tbxManagersCosts.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub

Private Sub tbxSaleMarge_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxSaleMarge_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    Dim oTbx As Object
    Set oTbx = tbxSaleMarge
    s = "|46|44|"
    If oTbx.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, oTbx.Value, ".", 1) Or InStr(1, oTbx.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    
    If Chr(KeyAscii) = "-" Then
        If Left(oTbx.Value, 1) = "-" Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    s = "|46|44|45|"
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub

Private Sub tbxSaleSelfCost_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxSaleSelfCost_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    s = "|46|44|"
    If tbxSaleSelfCost.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, tbxSaleSelfCost.Value, ".", 1) Or InStr(1, tbxSaleSelfCost.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub
'Page3
Private Sub tbxMagreNonTax_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    Dim oTbx As Object
    Set oTbx = tbxMagreNonTax
    s = "|46|44|"
    If oTbx.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, oTbx.Value, ".", 1) Or InStr(1, oTbx.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    
    If Chr(KeyAscii) = "-" Then
        If Left(oTbx.Value, 1) = "-" Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    s = "|46|44|45|"
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub

Private Sub tbxTwinActives_Change()
    CheckFillPage Me.MultiPage1.Value
End Sub

Private Sub tbxTwinActives_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim s As String
    s = "|46|44|"
    If tbxTwinActives.TextLength = 0 And InStr(1, s, "|" & KeyAscii & "|", 1) Then
        KeyAscii = 0
        Exit Sub
    End If
    If InStr(1, s, "|" & KeyAscii & "|", 1) Then
        If InStr(1, tbxTwinActives.Value, ".", 1) Or InStr(1, tbxTwinActives.Value, ",", 1) Then
            KeyAscii = 0
            Exit Sub
        End If
    End If
    If (KeyAscii < 48 Or KeyAscii > 58) And InStr(1, s, "|" & KeyAscii & "|", 1) = 0 Then
        KeyAscii = 0
        Exit Sub
    End If
End Sub


Private Sub UserForm_Initialize()
    Dim ws As Worksheet, lc As Long, lr As Long
    Dim s As String
    
    MultiPage1.Style = fmTabStyleNone '2
    MultiPage1.Value = 0
    btnOk.Caption = "Далее"
    Set ws = ThisWorkbook.Sheets(sRENTAB_ShName)
    lc = ws.Cells(lRENTAB_Year_ROW, ws.Columns.Count).End(xlToLeft).Column + 1
    aRentab = GetItemsArr(ws, lRENTAB_ActionType_COL, 1, 1, lc)
    For lc = lRENTAB_FstData_COL To UBound(aRentab, 2) - 1 Step 2
        If aRentab(lRENTAB_Year_ROW, lc) <> "" Then
            cbxYear.AddItem ""
            cbxYear.List(lr, 0) = Left(aRentab(lRENTAB_Year_ROW, lc), 4)
            cbxYear.List(lr, 1) = lc
            lr = lr + 1
        End If
    Next lc
    
    GetList ws, Me.cbxActionType1
    If cbxActionType1.ListCount > 0 Then
        ComboListAutoSize Me.cbxActionType1
    End If
End Sub

Function GetList(ws As Worksheet, oCbx As Object, _
                 Optional iIndent As Long = 0, _
                 Optional sCr As String = "*")
    Dim lr As Long
    Dim s As String
    Dim ares(), lcnt As Long
    Dim bWrite As Boolean
    Dim lNowIndent As Long
    
    oCbx.Clear
    oCbx.Value = ""
    bWrite = True
    For lr = lRENTAB_Fst_ROW To UBound(aRentab, 1)
        s = aRentab(lr, lRENTAB_ActionType_COL)
        s = Application.Trim(s)
        s = Application.Clean(s)
        s = Replace(s, "в том числе:", "")
        s = Replace(s, "в том числе", "")
        s = Application.Trim(s)
        If Len(s) Then
            If bWrite Then
                lNowIndent = GetIndent(ws.Cells(lr, lRENTAB_ActionType_COL))
                If lNowIndent = iIndent Then
                    oCbx.AddItem ""
                    oCbx.List(lcnt, 0) = s
                    oCbx.List(lcnt, 1) = lr
                    lcnt = lcnt + 1
                Else
                    If lNowIndent < iIndent Then bWrite = False
                End If
            End If
            If s Like sCr Then
                bWrite = True
            End If
        End If
    Next
End Function

Function GetNormatives(lP As Long)
    'заполненность комбобоксов
    If Me.cbxActionType2.ListCount = 0 Then
        Me.cbxActionType2.BackColor = Me.BackColor
    Else
        Me.cbxActionType2.BackColor = vbWhite
    End If
    If Me.cbxActionType3.ListCount = 0 Then
        Me.cbxActionType3.BackColor = Me.BackColor
    Else
        Me.cbxActionType3.BackColor = vbWhite
    End If
    
    CheckFillPage lP
    'основной код
    Dim lr As Long, ly As Long
    Dim lc As Long, ly_col As Long
    ly = Val(Me.cbxYear.Value)
    If ly = 0 Then
        Me.tbxNorm1.Value = ""
        Me.tbxNorm2.Value = ""
        
        Exit Function
    End If
    
    ly_col = Val(Me.cbxYear.List(Me.cbxYear.ListIndex, 1))
    If ly_col = 0 Then Exit Function
    
    If Me.cbxActionType3.Value <> "" Then
        lr = Me.cbxActionType3.List(Me.cbxActionType3.ListIndex, 1)
        Me.tbxNorm1.Value = aRentab(lr, ly_col)
        Me.tbxNorm2.Value = aRentab(lr, ly_col + 1)
        GoTo END_
    End If
    If Me.cbxActionType2.Value <> "" Then
        lr = Me.cbxActionType2.List(Me.cbxActionType2.ListIndex, 1)
        Me.tbxNorm1.Value = aRentab(lr, ly_col)
        Me.tbxNorm2.Value = aRentab(lr, ly_col + 1)
        GoTo END_
    End If
    If Me.cbxActionType1.Value <> "" Then
        lr = Me.cbxActionType1.List(Me.cbxActionType1.ListIndex, 1)
        Me.tbxNorm1.Value = aRentab(lr, ly_col)
        Me.tbxNorm2.Value = aRentab(lr, ly_col + 1)
        GoTo END_
    End If
END_:
    If lr > 0 Then
        Me.tbxAverageProductRent.Value = My_Round(Txt2Num(Me.tbxNorm1.Value, True) * 0.9, 2)
        Me.tbxAverageActivesRent.Value = My_Round(Txt2Num(Me.tbxNorm2.Value, True) * 0.9, 2)
    End If
End Function

Function GetRent(Optional IsNeedClose As Boolean = False)
    Dim vRentProd, vRentActives
    Me.tbxAverageProductRent.Value = My_Round(Txt2Num(Me.tbxNorm1.Value, True) * 0.9, 2)
    Me.tbxAverageActivesRent.Value = My_Round(Txt2Num(Me.tbxNorm2.Value, True) * 0.9, 2)
    
    vRentProd = РЕНТ_ПРОДАЖ(Txt2Num(Me.tbxSaleMarge.Value, True), Txt2Num(Me.tbxSaleSelfCost.Value, True), Txt2Num(Me.tbxKommercialCosts.Value, True), Txt2Num(Me.tbxManagersCosts.Value, True))
    vRentActives = РЕНТАБАКТИВ(Txt2Num(Me.tbxMagreNonTax.Value, True), Txt2Num(Me.tbxTwinActives.Value, True))
    vRentProd = My_Round((vRentProd), 2)
    vRentActives = My_Round((vRentActives), 2)
    
    tbxrent_r_text = IIf(vRentProd <> 0, vRentProd, "")
    tbxrenta_r_text = IIf(vRentActives <> 0, vRentActives, "")
    Call init_tbxrent_r(tbxrent_r, tbxrent_r_text)
    Call init_tbxrenta_r(tbxrenta_r, tbxrenta_r_text)
    
    EvalRent_Res vRentProd, vRentActives, Txt2Num(Me.tbxAverageProductRent.Value, True), Txt2Num(Me.tbxAverageActivesRent.Value, True)
    
    If IsNeedClose Then Unload Me
End Function

Function CheckFillPage(lP As Long)
    Dim arr, x, bb As Boolean
    
    bb = True
    Select Case lP
    Case 0
        arr = Array("cbxYear", "cbxActionType1")
        For Each x In arr
            If Me.Controls(x).Value = "" Then
                bb = False
                Exit For
            End If
        Next
        btnOk.Caption = "Далее"
    Case 1
        arr = Array("tbxSaleMarge", "tbxSaleSelfCost", "tbxKommercialCosts", "tbxManagersCosts")
        For Each x In arr
            If Me.Controls(x).Value = "" Then
                bb = False
                Exit For
            End If
        Next
        btnOk.Caption = "Далее"
    Case 2
        arr = Array("tbxMagreNonTax", "tbxTwinActives")
        For Each x In arr
            If Me.Controls(x).Value = "" Then
                bb = False
                Exit For
            End If
        Next
        btnOk.Caption = "РАССЧИТАТЬ"
    End Select
    btnOk.Enabled = bb
    CheckFillPage = bb
End Function

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
Option Explicit


Attribute VB_Name = "mRentab"
Option Explicit

Public Const sRENTAB_ShName As String = "rentab"
Public Const sRENTAB_Eval_ShName As String = "rentab_eval"
Public Const sRENTAB_Result_ShName As String = "РЕЗУЛЬТАТ"
Public Const sRENTAB_Result_CellAddr As String = "A5"

Public Const lRENTAB_ActionType_COL As Long = 1
Public Const lRENTAB_FstData_COL As Long = 2
Public Const lRENTAB_Year_ROW As Long = 1
Public Const lRENTAB_Fst_ROW As Long = 3

Sub FinDir_GetRent(control As IRibbonControl)
    ufGetRentab.Show 0
End Sub

'Рен_ПРОД=Приб_ПРОД/(C_ПРОД+ КОМ_РАСХ+ УПР_РАСХ)*100%
Function РЕНТ_ПРОДАЖ(Приб_ПРОД, C_ПРОД, КОМ_РАСХ, УПР_РАСХ)
    On Error Resume Next
    РЕНТ_ПРОДАЖ = Приб_ПРОД / (C_ПРОД + КОМ_РАСХ + УПР_РАСХ) * 100
End Function

Function EvalRent_Res(vRentProd, vRentActives, vAverageProductRent, vAverageActivesRent)
    Dim arr, lr As Long
    With ThisWorkbook.Sheets(sRENTAB_Eval_ShName)
        .Range("_RentProd").Value = vRentProd
        .Range("_AverageProductRent").Value = vAverageProductRent
        .Range("_RentActives").Value = vRentActives
        .Range("_AverageActivesRent").Value = vAverageActivesRent
        If Txt2Num(ufGetRentab.tbxNorm1.Value, True) = 0 Then
            .Range("_NormRentProd").Value = "отр"
        Else
            .Range("_NormRentProd").Value = "пол"
        End If
        If Txt2Num(ufGetRentab.tbxNorm2.Value, True) = 0 Then
            .Range("_NormActives").Value = "отр"
        Else
            .Range("_NormActives").Value = "пол"
        End If
        
        .Calculate
        arr = .Range("_rent.res_table").Value
    End With
    tbxrent_result_text = ""
    For lr = LBound(arr, 1) To UBound(arr, 1)
        If arr(lr, 1) = True Then
            'выводим результаты на лист
            ThisWorkbook.Sheets(sRENTAB_Result_ShName).Copy
            With Sheets(sRENTAB_Result_ShName)
                .Range(sRENTAB_Result_CellAddr).Value = arr(lr, 2) & Chr(10) & Chr(10) & arr(lr, 3)
                If arr(lr, 4) = "проверка маловероятна" Then
                    .Shapes("_hight").Visible = False
                Else
                    .Shapes("_low").Visible = False
                End If
                .Range("A1").Select
                .ScrollArea = "A1"
            End With
            'в ленту
            tbxrent_result_text = CStr(arr(lr, 4))
            Exit For
        End If
    Next
    Call init_tbxrent_result(tbxrent_result, tbxrent_result_text)
End Function

Attribute VB_Name = "mFuncs_F"
'---------------------------------------------------------------------------------------
' Module    : mFuncs_F
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit
'для формы
Public Const lMAX_VisibleARGS As Long = 5

'Ликвидность
Function ЛИКВИДНОСТЬА(Наиб_лик_об_активы, Текущ_обязательства)
    On Error Resume Next
    ЛИКВИДНОСТЬА = Наиб_лик_об_активы / Текущ_обязательства
End Function
Function ЛИКВИДНОСТЬТ(Ликвид_активы, Текущ_обязательства)
    On Error Resume Next
    ЛИКВИДНОСТЬТ = Ликвид_активы / Текущ_обязательства
End Function
Function ЛИКВИДНОСТЬОБ(Оборот_активы, Кр_обязательства)
    On Error Resume Next
    ЛИКВИДНОСТЬОБ = Оборот_активы / Кр_обязательства
End Function

'Платежеспособность
Function ПЛАТЕЖЕСПОСТО(Текущ_обязательства, Выручка_средн)
    On Error Resume Next
    ПЛАТЕЖЕСПОСТО = Текущ_обязательства / Выручка_средн
End Function
Function ОБЯЗАТЕЛЬСТВАТ(Заемн_ср_кр, Кредит_задолж, Пр_обязат_кр)
    On Error Resume Next
    ОБЯЗАТЕЛЬСТВАТ = Заемн_ср_кр + Кредит_задолж + Пр_обязат_кр
End Function
Function ЛИКВИДАКТИВ(Наиб_лик_об_активы, Кр_дебитор_задол, Пр_об_активы)
    On Error Resume Next
    ЛИКВИДАКТИВ = Наиб_лик_об_активы + Кр_дебитор_задол + Пр_об_активы
End Function
Function УТРПЛАТЕЖ(Тек_ликвид_кон_п, Тек_ликвид_нач_п, Прогноз_пер, Отчет_пер, Норм_тек_ликвид)
    On Error Resume Next
    УТРПЛАТЕЖ = (Тек_ликвид_кон_п + (Прогноз_пер / Отчет_пер) * (Тек_ликвид_кон_п - Тек_ликвид_нач_п)) / Норм_тек_ликвид
End Function
Function ВОССТПЛАТЕЖ(Тек_ликвид_кон_п, Тек_ликвид_нач_п, Прогноз_пер, Отчет_пер, Норм_тек_ликвид)
    On Error Resume Next
    ВОССТПЛАТЕЖ = (Тек_ликвид_кон_п + (Прогноз_пер / Отчет_пер) * (Тек_ликвид_кон_п - Тек_ликвид_нач_п)) / Норм_тек_ликвид
End Function

'Финансовая  устойчивость
Function КАВТОНОМИИ(Соб_капитал, Совокуп_пассивы)
    On Error Resume Next
    КАВТОНОМИИ = Соб_капитал / Совокуп_пассивы
End Function
Function ФИНРЫЧАГ(Долгоср_обязат, Краткоср_обязат_кор, Соб_капитал)
    On Error Resume Next
    ФИНРЫЧАГ = (Долгоср_обязат + Краткоср_обязат_кор) / Соб_капитал
End Function
Function КПРИВЛДОЛГСРЗС(Долгоср_обязат, Совокуп_активы)
    On Error Resume Next
    КПРИВЛДОЛГСРЗС = Долгоср_обязат / Совокуп_активы
End Function
Function СООТНОШСЗСР(Собств_средства, Долгоср_обязат, Долгоср_оц_обязат, Краткоср_обязат, Доход_буд_период, Краткоср_оц_обязат)
    On Error Resume Next
    СООТНОШСЗСР = Собств_средства / ((Долгоср_обязат + Краткоср_обязат) - (Краткоср_оц_обязат + Долгоср_оц_обязат + Доход_буд_период))
End Function
Function РЕНТАБПРОДАЖ(Прибыль_продаж, Выручка)
    On Error Resume Next
    РЕНТАБПРОДАЖ = Прибыль_продаж / Выручка * 100
End Function
Function РЕНТАБДЕЯТЕЛ(Чист_прибыль, Выручка)
    On Error Resume Next
    РЕНТАБДЕЯТЕЛ = Чист_прибыль / Выручка * 100
End Function
Function РЕНТАБСК(Чист_прибыль, Соб_капитал)
    On Error Resume Next
    РЕНТАБСК = Чист_прибыль / Соб_капитал * 100
End Function
Function РЕНТАБАКТИВ(Чист_прибыль, Совокуп_активы)
    On Error Resume Next
    РЕНТАБАКТИВ = Чист_прибыль / Совокуп_активы * 100
End Function

'Оборачиваемость
Function ПЕРИОДОБДЗ(Дебит_задолж, Отчет_пер, Выручка)
    On Error Resume Next
    ПЕРИОДОБДЗ = Отчет_пер * (Дебит_задолж / Выручка)
End Function
Function ПЕРИОДОБЗ(Запасы_нач_п, Запасы_кон_п, Отчет_пер, Себестоимость)
    On Error Resume Next
    ПЕРИОДОБЗ = Отчет_пер * (((Запасы_нач_п + Запасы_кон_п) / 2) / Себестоимость)
End Function
Function ПЕРИОДОБКЗ(Кредит_задолж, Отчет_пер, Себестоимость)
    On Error Resume Next
    ПЕРИОДОБКЗ = Отчет_пер * (Кредит_задолж / Себестоимость)
End Function
Function ОПЕРЦИКЛ(Пер_обор_запасов, Пер_обор_дебитор)
    On Error Resume Next
    ОПЕРЦИКЛ = Пер_обор_запасов + Пер_обор_дебитор
End Function
Function ФИНЦИКЛ(Опер_цикл, Пер_обор_кредитор)
    On Error Resume Next
    ФИНЦИКЛ = Опер_цикл - Пер_обор_кредитор
End Function

'Безубыточный объем продаж
Function МАРЖДОХОД(Выручка, Перем_затраты)
    On Error Resume Next
    МАРЖДОХОД = Выручка - Перем_затраты
End Function
Function ТОЧКАБЕЗУБЫТ(Выручка, Пост_затраты, Марж_доход)
    On Error Resume Next
    ТОЧКАБЕЗУБЫТ = (Выручка * Пост_затраты) / Марж_доход
End Function
Function ЗАПФИНПРОЧ(Выручка, Точка_безубыт)
    On Error Resume Next
    ЗАПФИНПРОЧ = ((Выручка - Точка_безубыт) / Выручка) * 100
End Function
Function СТДИСКОНТИРЗК(Ст_кредит, Ст_нал_приб)
    On Error Resume Next
    СТДИСКОНТИРЗК = (Ст_кредит * (1 - Ст_нал_приб)) * 100
End Function
Function СТДИСКОНТИРСК(Ст_безриск, Премия_риск)
    On Error Resume Next
    СТДИСКОНТИРСК = Ст_безриск + Премия_риск
End Function
Function СТДИСКОНТИРСМК(Ст_кредит, Ст_нал_приб, Доля_заем_средств, Ст_дисконт_соб_кап, Доля_акционер_кап)
    On Error Resume Next
    СТДИСКОНТИРСМК = (Ст_кредит * (1 - Ст_нал_приб) * Доля_заем_средств + Ст_дисконт_соб_кап * Доля_акционер_кап) * 100
End Function
Function РАСХОТСРОЧПЛ(Сумм_сделки, Ст_кредит, Пер_отсрочки)
    On Error Resume Next
    РАСХОТСРОЧПЛ = Сумм_сделки * Ст_кредит * Пер_отсрочки
End Function
Function ПРЕДЕЛОТСРОЧ(Чист_приб_отсрочк, Стоим_отгруз_отсрочк, Стоим_привл_ср)
    On Error Resume Next
    ПРЕДЕЛОТСРОЧ = Чист_приб_отсрочк / (Стоим_отгруз_отсрочк * Стоим_привл_ср)
End Function
Function ПЕРИОДОТСРОЧ(Сумм_сделки, Мин_рент_продаж, Ст_кредит)
    On Error Resume Next
    ПЕРИОДОТСРОЧ = (Сумм_сделки * Мин_рент_продаж) / (Сумм_сделки * Ст_кредит)
End Function
'НАЛОГИ
'ЕСН
Function СОЦВЗНОС(Доходы As Range, _
                ДенПорог1 As Double, СтавкаДоП1 As Double, СтавкаПосле As Double, _
                Optional СтавкаДоП2 As Double, Optional ДенПорог2 As Double, _
                Optional ИсключитьНДФЛ As Boolean = False, Optional НДФЛ As Double = 0.13)
    Application.Volatile
    Dim dblNDFL_ToCalc As Double, Base As Double, Base2 As Double, bTmp As Double
    Dim dblActMonth As Double, vv As Double, dblTmpSum As Double
    Dim rs As Long, IsNeedTransp As Boolean
    Dim b(), arrVal
    
    dblNDFL_ToCalc = 1 - НДФЛ
    Base = ДенПорог1
    Base2 = ДенПорог2
    bTmp = 0
    If (Base2 = 0) Then
        Base2 = 999999999
        СтавкаДоП2 = СтавкаПосле
    End If
    If (ИсключитьНДФЛ = False) Then dblNDFL_ToCalc = 1 'если надо вычитать НДФЛ из совокупного дохода
    ReDim b(1 To 12, 1 To 12)
    dblActMonth = 0
    vv = 0
    dblTmpSum = 0
    rs = 0
    IsNeedTransp = False

    arrVal = Доходы.Value
    If (Доходы.Rows.Count > 1) Then 'если вертикальный массив
        If (Доходы.Columns.Count = 1) Then
            arrVal = MyTranspose(arrVal)
            IsNeedTransp = True
        Else
            СОЦВЗНОС = b
            Exit Function
        End If
    End If
    
    rs = UBound(arrVal, 1)
    Dim c As Long, r As Long, v
    For c = 1 To 12
        dblActMonth = 0
        For r = 1 To rs 'необходимо, если суммы будут разбиты на статьи(задел на будущее)
            v = arrVal(r, c)
            If (v = "") Then
                v = 0
            Else
                If IsNumeric(v) Then v = CDbl(v)
            End If
            dblActMonth = dblActMonth + v / dblNDFL_ToCalc
            If (dblActMonth <> 0) Then
                vv = vv + dblActMonth
                If (vv > Base) Then
                    'общие начисление минус сумма текущего месяца
                    'в результате получаем сумму, на которую уже начислили налог
                    dblTmpSum = vv - dblActMonth
                    If (vv < Base2) Then
                        If (dblTmpSum < Base) Then
                            bTmp = ((Base - dblTmpSum) * СтавкаДоП1) + ((vv - Base) * СтавкаДоП2)
                        Else
                            bTmp = dblActMonth * СтавкаДоП2
                        End If
                    Else
                        If (dblTmpSum < Base2) Then
                            bTmp = ((Base2 - dblTmpSum) * СтавкаДоП2) + ((vv - Base2) * СтавкаПосле)
                        Else
                            bTmp = dblActMonth * СтавкаПосле
                        End If
                    End If
                Else 'if (vv > Base)
                    bTmp = dblActMonth * СтавкаДоП1
                End If
            Else 'if (dblActMonth <> 0)
                bTmp = 0
            End If
            
            If (IsNeedTransp = False) Then
                b(r, c) = bTmp
            Else
                b(c, r) = bTmp
            End If
        Next r
    Next c
    СОЦВЗНОС = b
End Function



Attribute VB_Name = "ufCreateFunc_F"
Attribute VB_Base = "0{60E7C6C9-AC7B-4361-A35E-84882FEAD162}{CEE40757-9DCB-42FD-B861-4EE02797C9A4}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

Const lStep_Offset_Cntrl As Long = 24

Private Sub fmDescr_Click()

End Sub

Private Sub scrlArgs_Change()
    Dim oCntrl As control, lCntrlCnt As Long
    'определяем надо ли обрабатывать событие
    lCntrlCnt = 0
    For Each oCntrl In Me.Controls
'        If Left(oCntrl.name, 6) = "refArg" Or Left(oCntrl.name, 6) = "tbxArg" And oCntrl.name <> "lblArgDescript" Then
        If Left(oCntrl.Name, 6) = "lblArg" Then
            If oCntrl.Visible Then
                lCntrlCnt = lCntrlCnt + 1
            End If
        End If
    Next oCntrl

    If lCntrlCnt > lMAX_VisibleARGS Then
        If scrlArgs.Value <= scrlArgs.Max And lScrollVal > 0 Then
            frArgs.Top = 6 + (-(scrlArgs.Value - 1) * lStep_Offset_Cntrl)
'            For Each oCntrl In Me.Controls
'                If Left(oCntrl.Name, 6) = "refArg" Or Left(oCntrl.Name, 6) = "lblArg" Or Left(oCntrl.Name, 6) = "tbxArg" And oCntrl.Name <> "lblArgDescript" Then
'                    Select Case True
'                        Case lScrollVal < scrlArgs.Value
'                            oCntrl.Top = oCntrl.Top - lStep_Offset_Cntrl
'                        Case lScrollVal > scrlArgs.Value
'                            oCntrl.Top = oCntrl.Top + lStep_Offset_Cntrl
'                    End Select
'                End If
'            Next oCntrl
            If Me.Controls("refArg" & scrlArgs.Value + (lMAX_VisibleARGS - 1)).Visible Then
                Me.Controls("refArg" & scrlArgs.Value + (lMAX_VisibleARGS - 1)).SetFocus
            End If
            If Me.Controls("tbxArg" & scrlArgs.Value + (lMAX_VisibleARGS - 1)).Visible Then
                Me.Controls("tbxArg" & scrlArgs.Value + (lMAX_VisibleARGS - 1)).SetFocus
            End If
'            If Me.Controls("refArg" & scrlArgs.Value).Visible Then
'                Me.Controls("refArg" & scrlArgs.Value).SetFocus
'            End If
'            If Me.Controls("tbxArg" & scrlArgs.Value).Visible Then
'                Me.Controls("tbxArg" & scrlArgs.Value).SetFocus
'            End If
        End If
    End If
    '    Call Set_ArgDescript(scrlArgs.Value)
End Sub

Private Sub scrlArgs_Scroll()
    scrlArgs.Value = lScrollVal
End Sub

Private Sub cmndbCancel_Click()
bFormNonEvents = True
10        Unload Me
bFormNonEvents = False
End Sub

Private Sub cmndbOK_Click()
    Dim li As Long, sFuncArgs As String, vTmp, avTmp
    Dim s As String

    sFuncArgs = ""
    For li = LBound(asSyntacs) To UBound(asSyntacs)
        vTmp = Me.Controls(asControlType(li) & "Arg" & li + 1).Value
        If asControlType(li) = "ref" Then
            If vTmp <> "" Then
                On Error Resume Next
                avTmp = Application.ConvertFormula(vTmp, FromReferenceStyle:=Application.ReferenceStyle, _
                                                   ToReferenceStyle:=Application.ReferenceStyle, ToAbsolute:=xlRelative)
                s = Application.ConvertFormula(vTmp, FromReferenceStyle:=Application.ReferenceStyle, ToReferenceStyle:=xlA1, ToAbsolute:=xlRelative)
                If Left(vTmp, Len(ActiveSheet.Name) + 3) Like "*'" & ActiveSheet.Name & "'!" Or Left(vTmp, Len(ActiveSheet.Name) + 1) Like "*" & ActiveSheet.Name & "!" Then
                    s = Mid(s, InStrRev(s, "!") + 1)
                End If
                On Error GoTo 0
                If Not IsError(avTmp) Then
                    If Not IsRange(s) Then
                        avTmp = Txt2Num(CStr(vTmp))
                    Else
                        vTmp = s 'avTmp
                    End If
                Else
                    vTmp = Txt2Num(CStr(vTmp))
                End If
            End If
        End If
        If asControlType(li) = "tbx" Then
            Select Case asDataType(li)
            Case "txt", "var"
                vTmp = Replace(vTmp, Chr(34), Chr(34) & Chr(34))
                vTmp = Chr(34) & vTmp & Chr(34)
            Case "int"
                vTmp = Val(vTmp)
            Case "bool"
                If LCase(vTmp) = "true" Or LCase(vTmp) = "истина" Or LCase(vTmp) = "1" Then
                    vTmp = True
                Else
                    vTmp = False
                End If
            End Select

        End If
        sFuncArgs = sFuncArgs & "," & vTmp
    Next li
    sFuncArgs = Mid$(sFuncArgs, 2)
    On Error Resume Next
    If bIsFormulaArray Then
        Selection.FormulaArray = "=" & fmArgFunc.Caption & "(" & sFuncArgs & ")"
    Else
        ActiveCell.Formula = "=" & fmArgFunc.Caption & "(" & sFuncArgs & ")"
    End If
    Unload Me
End Sub

Private Sub lblExamples_Click()
    Dim wShell As Object
    Set wShell = CreateObject("WScript.Shell")
    
    If Left(lblExamples.Tag, 4) = "http" Then
        wShell.Run lblExamples.Tag, 3
    Else
        MsgBox "Неверная ссылка", vbInformation, sAPP_NAME
    End If
'    ThisWorkbook.FollowHyperlink lblExamples.Tag
End Sub

Private Sub lblHelp_Click()
    Dim wShell As Object
    Set wShell = CreateObject("WScript.Shell")
    If Left(lblHelp.Tag, 4) = "http" Then
        wShell.Run lblHelp.Tag, 3
    Else
        MsgBox "Неверная ссылка", vbInformation, sAPP_NAME
    End If
'    ThisWorkbook.FollowHyperlink lblHelp.Tag
End Sub

Private Sub refArg1_Enter()
10        Set_ArgDescript 1, Me
End Sub
Private Sub refArg2_Enter()
10        Set_ArgDescript 2, Me
End Sub
Private Sub refArg3_Enter()
10        Set_ArgDescript 3, Me
End Sub
Private Sub refArg4_Enter()
10        Set_ArgDescript 4, Me
End Sub
Private Sub refArg5_Enter()
10        Set_ArgDescript 5, Me
End Sub
Private Sub refArg6_Enter()
10        Set_ArgDescript 6, Me
End Sub
Private Sub refArg7_Enter()
10        Set_ArgDescript 7, Me
End Sub
Private Sub refArg8_Enter()
10        Set_ArgDescript 8, Me
End Sub

Private Sub tbxArg1_Enter()
10        Set_ArgDescript 1, Me
End Sub
Private Sub tbxArg2_Enter()
10        Set_ArgDescript 2, Me
End Sub
Private Sub tbxArg3_Enter()
10        Set_ArgDescript 3, Me
End Sub
Private Sub tbxArg4_Enter()
10        Set_ArgDescript 4, Me
End Sub
Private Sub tbxArg5_Enter()
10        Set_ArgDescript 5, Me
End Sub
Private Sub tbxArg6_Enter()
10        Set_ArgDescript 6, Me
End Sub
Private Sub tbxArg7_Enter()
10        Set_ArgDescript 7, Me
End Sub
Private Sub tbxArg8_Enter()
10        Set_ArgDescript 8, Me
End Sub

Private Sub UserForm_Initialize()
…