Attribute VB_Name = "projbudg"

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const HKEY_CURRENT_USER = &H80000001

#If Win64 Then
    Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Private Declare PtrSafe Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Private Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Private Declare PtrSafe Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Private Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
#Else
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
    Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
#End If

' -------------------------------------------------------------------------------------------------------
Public Sub AlgActivate(ByVal ws As Worksheet, ByVal bUsePB As Boolean)
    Dim i As Integer, j As Integer, cAddr As String, cAlgText As String, cAlgText0 As String _
        , iVal As Integer, cCol As String, iRow As Long, cFormula As String, cCurrFormula As String _
        , k As Integer, iPos1 As Integer, iPos2 As Integer, cName As String, cGrafa As String _
        , cTerm As String, cReplace As String, Addr() As String, AlgText() As String _
        , AlgText0() As String, iCount As Integer, wSheet As Worksheet, iMin As Long _
        , iMax As Long, AlgTerm() As String, ReplaceTerm() As String, TermCount As Integer
        
    On Error GoTo doError
    
    Set wSheet = ws
    i = 0
    iMin = 100000
    iMax = 0
    For j = 1 To wSheet.Scripts.count
        If VBA.InStr(wSheet.Scripts(j).ID, "alg_term_") > 0 Then
            cAddr = VBA.Trim(VBA.Mid(wSheet.Scripts(j).ID, 1 + VBA.Len("alg_term_")))
            cAlgText = VBA.Trim(wSheet.Range(cAddr).Text)
            cAlgText0 = VBA.Trim(GetStrParam(wSheet.Scripts(j).ScriptText, 2))
            i = i + 1
            ReDim Preserve Addr(i), AlgText(i), AlgText0(i)
            Addr(i) = cAddr
            AlgText(i) = cAlgText
            AlgText0(i) = cAlgText0
        End If
        If VBA.InStr(wSheet.Scripts(j).ID, "sql_term_") > 0 Then
            cAddr = VBA.Trim(VBA.Mid(wSheet.Scripts(j).ID, 1 + VBA.Len("sql_term_")))
            iVal = VBA.Val(VBA.Mid(cAddr, VBA.InStr(2, cAddr, "$") + 1))
            If iVal < iMin Then iMin = iVal
            If iVal > iMax Then iMax = iVal
        End If
    Next j
    iCount = i
    TermCount = 9
    ReDim AlgTerm(TermCount), ReplaceTerm(TermCount)
    AlgTerm(1) = "сумм(#)"
    ReplaceTerm(1) = "SUM(#)"
    AlgTerm(2) = "сред(#)"
    ReplaceTerm(2) = "AVERAGE(#)"
    AlgTerm(3) = "наибол(#)"
    ReplaceTerm(3) = "MAX(#)"
    AlgTerm(4) = "наимен(#)"
    ReplaceTerm(4) = "MIN(#)"
    AlgTerm(5) = "если(#)"
    ReplaceTerm(5) = "IF(#)"
    AlgTerm(6) = "пред(#)"
    ReplaceTerm(6) = "#"
    AlgTerm(7) = "след(#)"
    ReplaceTerm(7) = "#"
    AlgTerm(8) = "суммвверх(#)"
    ReplaceTerm(8) = "SUM(#)"
    AlgTerm(9) = "округл(#)"
    ReplaceTerm(9) = "ROUND(#)"

    For i = 1 To iCount
        If VBA.InStr(AlgText(i), "=") > 0 Then
            cCol = VBA.Left(Addr(i), VBA.InStr(2, Addr(i), "$") - 1)
            cFormula = VBA.Replace(VBA.Replace(VBA.LCase(AlgText(i)), "[", "("), "]", ")")
                
            For k = 1 To TermCount
                Do While VBA.InStr(cFormula, GetStrParam(AlgTerm(k), 1)) > 0
                    iPos1 = VBA.InStr(cFormula, GetStrParam(AlgTerm(k), 1))
                    iPos2 = GetFuncEnd(cFormula, iPos1)
                    If iPos1 < iPos2 Then
                        cTerm = VBA.Trim(VBA.Mid(cFormula, iPos1, iPos2 - iPos1 + 1))
                        
                        If k <> 5 And k <> 9 Then
                            cName = VBA.Trim(VBA.Mid(cTerm, VBA.Len(GetStrParam(AlgTerm(k), 1)) + 1, VBA.Len(cTerm) - VBA.Len(GetStrParam(AlgTerm(k), 1)) - VBA.Len(GetStrParam(AlgTerm(k), 2))))
                            For j = 1 To iCount
                                If VBA.InStr(AlgText(j), "=") > 0 Then
                                    cGrafa = VBA.Trim(VBA.Left(AlgText(j), VBA.InStr(AlgText(j), "=") - 1))
                                Else
                                    cGrafa = AlgText(j)
                                End If
                                cGrafa = VBA.LCase(cGrafa)
                                If i <> j And cGrafa = cName Then
                                    cReplace = VBA.Left(Addr(j), VBA.InStr(2, Addr(j), "$") - 1)
                                    Select Case k
                                    Case 1 To 4
                                        cReplace = GetStrParam(ReplaceTerm(k), 1) & cReplace & "$" & iMin & ":" & cReplace & "$" & iMax & GetStrParam(ReplaceTerm(k), 2)
                                    Case 6
                                        cReplace = GetStrParam(ReplaceTerm(k), 1) & cReplace & "$<<<row_id-1>>>" & GetStrParam(ReplaceTerm(k), 2)
                                    Case 7
                                        cReplace = GetStrParam(ReplaceTerm(k), 1) & cReplace & "$<<<row_id+1>>>" & GetStrParam(ReplaceTerm(k), 2)
                                    Case 8
                                        cReplace = GetStrParam(ReplaceTerm(k), 1) & cReplace & "$" & iMin & ":" & cReplace & "$<<<row_id>>>" & GetStrParam(ReplaceTerm(k), 2)
                                    End Select
                                    cFormula = VBA.Replace(cFormula, cTerm, cReplace)
                                    Exit For
                                End If
                            Next j
                        End If
                        
                        If k = 5 Or k = 9 Then
                            cReplace = cTerm
                            cReplace = VBA.Replace(cReplace, GetStrParam(AlgTerm(k), 1), GetStrParam(ReplaceTerm(k), 1))
                            cReplace = VBA.Replace(cReplace, GetStrParam(AlgTerm(k), 2), GetStrParam(ReplaceTerm(k), 2))
                            cReplace = VBA.Replace(cReplace, ";", ",")
                            cFormula = VBA.Replace(cFormula, cTerm, cReplace)
                        End If
                    End If
                Loop
            Next k
            
            For j = 1 To iCount
                If VBA.InStr(AlgText(j), "=") > 0 Then
                    cGrafa = VBA.Trim(VBA.Left(AlgText(j), VBA.InStr(AlgText(j), "=") - 1))
                Else
                    cGrafa = AlgText(j)
                End If
                cGrafa = VBA.LCase(cGrafa)
                If i <> j And VBA.InStr(cFormula, cGrafa) > 0 Then
                    cFormula = VBA.Replace(cFormula, cGrafa, VBA.Left(Addr(j), VBA.InStr(2, Addr(j), "$") - 1) & "<<<row_id>>>")
                End If
            Next j
            
            For j = 1 To wSheet.Scripts.count
                If VBA.InStr(wSheet.Scripts(j).ID, "sql_term_" & cCol) > 0 And bUsePB Then
                    cAddr = VBA.Trim(VBA.Mid(wSheet.Scripts(j).ID, 1 + VBA.Len("sql_term_")))
                    iRow = VBA.Val(VBA.Mid(cAddr, VBA.InStr(2, cAddr, "$") + 1))
                    cCurrFormula = cFormula
                    cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id>>>", VBA.Trim(VBA.str(iRow)))
                    cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id-1>>>", VBA.Trim(VBA.str(IIf((iRow - 1) < iMin, iMin, iRow - 1))))
                    cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id+1>>>", VBA.Trim(VBA.str(IIf((iRow + 1) > iMax, iMax, iRow + 1))))
                    wSheet.Range(cAddr).Formula = VBA.Mid(cCurrFormula, VBA.InStr(cCurrFormula, "="))
                End If

                If VBA.InStr(wSheet.Scripts(j).ID, "total_term_" & cCol) > 0 Then
                    If VBA.Val(wSheet.Scripts(j).ScriptText) = 4 Then
                        cAddr = VBA.Trim(VBA.Mid(wSheet.Scripts(j).ID, 1 + VBA.Len("total_term_")))
                        iRow = VBA.Val(VBA.Mid(cAddr, VBA.InStr(2, cAddr, "$") + 1))
                        cCurrFormula = cFormula
                        cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id>>>", VBA.Trim(VBA.str(iRow)))
                        cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id-1>>>", VBA.Trim(VBA.str(IIf((iRow - 1) < iMin, iMin, iRow - 1))))
                        cCurrFormula = VBA.Replace(cCurrFormula, "<<<row_id+1>>>", VBA.Trim(VBA.str(IIf((iRow + 1) > iMax, iMax, iRow + 1))))
                        wSheet.Range(cAddr).Formula = VBA.Mid(cCurrFormula, VBA.InStr(cCurrFormula, "="))
                    End If
                End If
            Next j
        End If
    Next i
    Exit Sub
    
doError:
    Call ShowErrorEvent("AlgActivate")
End Sub
' -------------------------------------------------------------------------------------------------------
' процедура подготовки алгоритмов и итоговых строк комментариев в тело страницы в виде VB скриптов
Public Sub Calc_Comments(s As String)
    Dim ws As Worksheet, Com As Comment, sParam As String, iParam As Integer

    On Error GoTo doError
    
    Application.Calculation = xlManual
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" Then
            For Each Com In ws.Comments
                sParam = VBA.LCase(VBA.Trim(GetStrParam(Com.Text, 1)))

                If VBA.Left(sParam, 9) = "algorithm" Then
                    sParam = VBA.Trim(GetStrParam(Com.Text, 2))
                    If VBA.Val(sParam) > 0 Then
                        ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                            ID:="alg_term_" + Com.Parent.Address(), ScriptText:=sParam + "#" + Com.Parent.Text
                    End If
                    Com.Parent.ClearComments
                End If

                If VBA.Left(sParam, 6) = "totals" Then
                    iParam = VBA.Val(VBA.Trim(GetStrParam(Com.Text, 2)))
                    If iParam > 0 Then
                        Select Case iParam
                        Case 2
                            Com.Parent.FormulaLocal = "=СУММЕСЛИ(ДВССЫЛ(""R1C1"";ЛОЖЬ):ДВССЫЛ(""R65000C1"";ЛОЖЬ);""=1"";ДВССЫЛ(""R1C[0]"";ЛОЖЬ):ДВССЫЛ(""R65000C[0]"";ЛОЖЬ))"
                        Case 3
                            Com.Parent.FormulaLocal = "=СУММЕСЛИ(ДВССЫЛ(""R1C1"";ЛОЖЬ):ДВССЫЛ(""R65000C1"";ЛОЖЬ);""=1"";ДВССЫЛ(""R1C[0]"";ЛОЖЬ):ДВССЫЛ(""R65000C[0]"";ЛОЖЬ))/СЧЕТЕСЛИ(ДВССЫЛ(""R1C1"";ЛОЖЬ):ДВССЫЛ(""R65000C1"";ЛОЖЬ);""=1"")"
                        Case 4
                            ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                                ID:="total_term_" + Com.Parent.Address(), ScriptText:=VBA.Trim(GetStrParam(Com.Text, 2))
                        Case Else
                            Com.Parent.Value = "X"
                        End Select
                    End If

                    iParam = VBA.InStr(VBA.InStr(Com.Text, "#") + 1, Com.Text, "#")
                    If iParam > 0 Then
                        Com.Parent.Comment.Text VBA.Mid(Com.Text, iParam + 1)
                    Else
                        Com.Parent.ClearComments
                    End If
                End If
            Next Com
        End If
    Next ws
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
    
doError:
    Call ShowErrorEvent("Calc_Comments")
End Sub
' -------------------------------------------------------------------------------------------------------
' процедура перевода значений в формулы
Public Sub Calc_Formula(s As String)
    Dim ws As Worksheet, curRange As Range, r As Range, nRow As Long, nCol As Long _
        , cDecimal As String, cFormula As String

    On Error GoTo doError
    
    cDecimal = RegistryGetValue(HKEY_CURRENT_USER, "Control Panel\International", "sDecimal")
    cDecimal = VBA.Trim(cDecimal)

    Application.Calculation = xlManual
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" Then
            Set curRange = ws.Rows("1:65535")
            Set r = curRange.Find("=", LookIn:=xlValues, LookAt:=xlPart)
            If Not r Is Nothing Then
                nRow = r.row
                nCol = r.column
                Do
                    If VBA.Left(r.Value, 1) = "=" Then
                        ' cFormula = VBA.Replace(r.Value, VBA.Chr(34), VBA.Chr(34) & VBA.Chr(34))
                        cFormula = r.Value

                        If cDecimal <> "" Then
                            cFormula = VBA.Replace(cFormula, ".", cDecimal)
                        End If

                        r.FormulaLocal = cFormula
                    End If
                    
                    Set r = curRange.FindNext(r)
                    If Not r Is Nothing Then
                        If nRow > r.row Or (nRow = r.row And nCol >= r.column) Then
                            Exit Do
                        End If
                        nRow = r.row
                        nCol = r.column
                    End If
                Loop While Not r Is Nothing
            End If
            Set r = Nothing
            
            Set r = curRange.Find("=", LookIn:=xlFormulas, LookAt:=xlPart)
            If Not r Is Nothing Then
                nRow = r.row
                nCol = r.column
                Do
                    If VBA.IsError(r.Value) Then
                        r.FormulaLocal = r.FormulaLocal
                    End If
                    
                    Set r = curRange.FindNext(r)
                    If Not r Is Nothing Then
                        If nRow > r.row Or (nRow = r.row And nCol >= r.column) Then
                            Exit Do
                        End If
                        nRow = r.row
                        nCol = r.column
                    End If
                Loop While Not r Is Nothing
            End If
            Set r = Nothing
            
        End If
    Next ws
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
    
doError:
    Call ShowErrorEvent("Calc_Formula")
End Sub
' -------------------------------------------------------------------------------------------------------
' процедура формирования точности в формате ячеек по значению в коментарии
Public Sub Calc_Toch(s As String)
    Dim i_toch As Integer, s_toch As String, Com As Comment, ws As Worksheet, pos As Integer, _
        ro As Long, co As Long, rn As Range, sValue As String, sSql As String, sToch As String, _
        d_toch As Double

    On Error GoTo doError
    
    Application.Calculation = xlManual
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" Then
                For Each Com In ws.Comments
                    pos = VBA.InStr(1, Com.Text, "#")
                    If pos <> 0 Then
                        d_toch = VBA.CDbl(VBA.Left(Com.Text, pos - 1))
                        Com.Parent.Comment.Text VBA.Right(Com.Text, VBA.Len(Com.Text) - pos)
                    Else
                        d_toch = VBA.CDbl(Com.Text)
                        Com.Parent.Comment.Text "#"
                    End If

                    s_toch = "#,##0"
                    i_toch = VBA.Int(VBA.Abs(d_toch))
                    If d_toch >= 0 Then
                        If i_toch > 0 Then
                            s_toch = s_toch & "." & VBA.String(i_toch, "0")
                        End If
                        Com.Parent.NumberFormat = s_toch
                        Com.Parent.HorizontalAlignment = -4152 'xlRight
                    Else
                        i_toch = VBA.Abs(i_toch)
                        If i_toch > 0 Then
                            s_toch = s_toch & "." & VBA.String(i_toch, "0")
                        End If
                        Com.Parent.NumberFormat = s_toch
                        Com.Parent.HorizontalAlignment = -4152 'xlRight
                        Com.Parent.Interior.ColorIndex = xlNone
                        Com.Parent.Locked = True
                    End If
                    If Com.Text = "#" Then Com.Delete
                Next Com
        End If
    Next ws
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
    
doError:
    Call ShowErrorEvent("Calc_Toch")
End Sub
' -------------------------------------------------------------------------------------------------------
' процедура копирования комментариев в тело страницы в виде VB скриптов
Public Sub Copy_Comments(s As String)
    Dim ws As Worksheet, Com As Comment, counter As Long, table_name As String, init_sql As String, _
        save_proc As String, tree_link As String

    On Error GoTo doError
    
    Application.Calculation = xlManual
    If Sheet_Find(Application.ActiveWorkbook, "Данные") Then
        table_name = Application.ActiveWorkbook.Worksheets("Данные").Range("TABLE_NAME").Value
        init_sql = Application.ActiveWorkbook.Worksheets("Данные").Range("INIT_SQL").Value
        save_proc = Application.ActiveWorkbook.Worksheets("Данные").Range("SAVE_PROC").Value
        If Names_Find(Application.ActiveWorkbook, "TREE_LINK") Then
            tree_link = Application.ActiveWorkbook.Worksheets("Данные").Range("TREE_LINK").Value
        Else
            tree_link = ""
        End If
    Else
        table_name = Application.ActiveWorkbook.Worksheets("Service").Range("A9").Value
        init_sql = Application.ActiveWorkbook.Worksheets("Service").Range("A10").Value
        save_proc = Application.ActiveWorkbook.Worksheets("Service").Range("A11").Value
        tree_link = Application.ActiveWorkbook.Worksheets("Service").Range("A12").Value
    End If

    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" Then
            For Each Com In ws.Comments
                ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                    ID:="sql_term_" + Com.Parent.Address(), ScriptText:=Com.Text
                Com.Parent.ClearComments
            Next Com
            
            If ws.Scripts.Count > 0 Then
                ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                    ID:="table_name", ScriptText:=VBA.Replace(table_name, "\", "_")
                ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                    ID:="init_sql", ScriptText:=VBA.Replace(init_sql, table_name, VBA.Replace(table_name, "\", "_"))
                ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                    ID:="save_proc", ScriptText:=VBA.Replace(save_proc, table_name, VBA.Replace(table_name, "\", "_"))
                ws.Scripts.Add Location:=msoScriptLocationInBody, Language:=msoScriptLanguageVisualBasic, _
                    ID:="tree_link", ScriptText:=tree_link
            End If
        End If
    Next ws
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
    
doError:
    Call ShowErrorEvent("Copy_Comments")
End Sub
' -------------------------------------------------------------------------------------------------------
Function GetFuncEnd(ByVal cString As String, ByVal nBeginPos As Long) As Long
    Dim npos As Long, nr As Long, nl As Long, nk As Long
    
    On Error GoTo doError
    
    npos = VBA.InStr(nBeginPos, cString, "(")
    nk = 0
    
    If npos > 0 Then
        nl = 1
        nr = 0
        Do While nl > nr And npos < VBA.Len(cString)
            npos = npos + 1
            nk = (nk + VBA.IIf(VBA.Mid(cString, npos, 1) = """", 1, 0)) Mod 2
            If nk = 0 Then
                nl = nl + VBA.IIf(VBA.Mid(cString, npos, 1) = "(", 1, 0)
                nr = nr + VBA.IIf(VBA.Mid(cString, npos, 1) = ")", 1, 0)
            End If
        Loop
    End If
    
    GetFuncEnd = npos
    Exit Function
    
doError:
    Call ShowErrorEvent("GetFuncEnd")
End Function
' -------------------------------------------------------------------------------------------------------
' функция, возвращает указанный параметр из строки параметров
Function GetStrParam(lcParam As String, ByVal lnParam As Integer) As String
    Dim nPos1 As Integer, nPos2 As Integer, i As Long

    On Error GoTo doError
    
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = InStr(nPos1 + 1, lcParam, "#")
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = InStr(nPos1 + 1, lcParam, "#")
    nPos2 = IIf(nPos2 = 0, Len(lcParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = Mid(lcParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
    Exit Function
    
doError:
    Call ShowErrorEvent("GetStrParam")
End Function
' -------------------------------------------------------------------------------------------------------
' процедура инициализации шаблонов отчетов класса "Учет ..." / способ через Excel
Public Sub Init_Uchet(s As String)
    On Error GoTo doError
    
    Calc_Comments ("")
    Calc_Toch ("")
    Copy_Comments ("")
    Init_Vba_Sheet ("")
    Protect_Sheets("")
    Exit Sub
    
doError:
    Call ShowErrorEvent("Init_Uchet")
End Sub
' -------------------------------------------------------------------------------------------------------
' процедура инициализации vba-скриптов на странице отчета
Public Sub Init_Vba_Sheet(s As String)
    Dim wb As Workbook, cPath As String, ws As Worksheet, bUsePB As Boolean
    
    On Error GoTo doError
    
    Set wb = Application.ActiveWorkbook
    If Sheet_Find(wb, "Service") Then
        cPath = VBA.Trim(wb.Sheets("Service").Range("A3").Text)
        If VBA.Right(cPath, 1) <> "\" And cPath <> "" Then
            cPath = cPath + "\"
        End If
                
        bUsePB = VBA.Val(wb.Sheets("Service").Range("A15").Value) > 0
    End If

    For Each ws In wb.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" And cPath <> "" Then
            Call AlgActivate(ws, bUsePB)
            If bUsePB Then
                wb.VBProject.VBComponents(ws.CodeName).CodeModule.AddFromFile (cPath & "MODULES\pb_client.bas")
            End If
        End If
    Next ws
    Exit Sub
    
doError:
    Call ShowErrorEvent("Init_Vba_Sheet")
End Sub
' -------------------------------------------------------------------------------------------------------
Public Function Names_Find(wb As Workbook, s As String) As Boolean
    Dim i As Integer

    On Error GoTo doError
    
    For i = 1 To wb.Names.count
        If wb.Names(i).name = s Then
            Names_Find = True
            Exit Function
        End If
    Next
    Names_Find = False
    Exit Function
    
doError:
    Call ShowErrorEvent("Names_Find")
End Function
' -------------------------------------------------------------------------------------------------------
' процедура, защищает страницу
Public Sub Protect_Sheets(s As String)
    Dim ws As Worksheet, lVal As Long

    On Error GoTo doError
    
    VBA.Randomize
    lVal = VBA.Int(VBA.Rnd() * 100000) * 10000 + VBA.Int(VBA.Rnd() * 100000)

    With Application.ActiveWorkbook.Sheets("Service")
        .Range("A1").Value = lVal
        .Range("A1").NumberFormat = "0"
        .Columns("A:A").ColumnWidth = 10
    End With

    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name <> "Service" And ws.name <> "Данные" And ws.name <> "Документ" Then
            If VBA.Val(Application.Version) = 9 Then
                ws.Protect Password:=MkChar(lVal, 10), DrawingObjects:=True, Contents:=True, Scenarios:=True
            End If
            If VBA.Val(Application.Version) > 9 Then
                Call ProtectSheetsAfter9(ws, MkChar(lVal, 10))
            End If
        End If
        If ws.name = "Service" Then
            ws.Protect Password:=MkChar(lVal, 10)
        End If
    Next ws
    Exit Sub
    
doError:
    Call ShowErrorEvent("Protect_Sheets")
End Sub
' -------------------------------------------------------------------------------------------------------
Public Sub ProtectSheetsAfter9(ws As Worksheet, s As String)
    On Error GoTo doError
    
    ws.Protect Password:=s, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFiltering:=True
    Exit Sub
    
doError:
    Call ShowErrorEvent("ProtectSheetsAfter9")
End Sub
' -------------------------------------------------------------------------------------------------------
Sub RegistryDelValue(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    
    On Error GoTo doError
    
    RegCreateKey hKey, strPath, Ret
    RegDeleteValue Ret, strValue
    RegCloseKey Ret
    Exit Sub
    
doError:
    Call ShowErrorEvent("RegistryDelValue")
End Sub
' -------------------------------------------------------------------------------------------------------
Function RegistryGetValue(hKey As Long, strPath As String, strValue As String)
    Dim Ret, lResult As Long, lValueType As Long, strBuf As String, lBufSize As Long, strData As Long, lType As Long
    
    On Error GoTo doError
    
    RegOpenKey hKey, strPath, Ret
    lResult = RegQueryValueEx(Ret, strValue, 0, lType, ByVal 0, lBufSize)
    If lResult = 0 Then
        Select Case lType
        Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_BINARY
            strBuf = VBA.String(lBufSize, VBA.Chr$(0))
            lResult = RegQueryValueEx(Ret, strValue, 0, 0, ByVal strBuf, lBufSize)
            If lResult = 0 Then
                If VBA.InStr(1, strBuf, VBA.Chr$(0)) > 0 Then
                    RegistryGetValue = VBA.Left$(strBuf, VBA.InStr(1, strBuf, VBA.Chr$(0)) - 1)
                Else
                    RegistryGetValue = strBuf
                End If
            End If
        
        Case REG_DWORD
            lResult = RegQueryValueEx(Ret, strValue, 0, 0, strData, lBufSize)
            If lResult = 0 Then
                RegistryGetValue = strData
            End If
        End Select
    End If
    RegCloseKey Ret
    Exit Function
    
doError:
    Call ShowErrorEvent("RegistryGetValue")
End Function
' -------------------------------------------------------------------------------------------------------
Sub RegistrySetValue(hKey As Long, strPath As String, strValue As String, strData As String, lType As Long)
    Dim Ret, lData As Long
    
    On Error GoTo doError
    
    RegCreateKey hKey, strPath, Ret
    Select Case lType
    Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ, REG_BINARY
        RegSetValueEx Ret, strValue, 0, lType, ByVal strData, VBA.Len(strData)
    Case REG_DWORD
        lData = VBA.Val(strData)
        RegSetValueEx Ret, strValue, 0, lType, lData, 4
    End Select
    RegCloseKey Ret
    Exit Sub
    
doError:
    Call ShowErrorEvent("RegistrySetValue")
End Sub
' -------------------------------------------------------------------------------------------------------
Public Function Sheet_Find(wb As Workbook, ws_name As String) As Boolean
    Dim tws As Worksheet, flag As Boolean

    On Error GoTo doError
    
    flag = False
    For Each tws In wb.Sheets
        If tws.name = ws_name Then flag = True
    Next tws
    Sheet_Find = flag
    Exit Function
    
doError:
    Call ShowErrorEvent("Sheet_Find")
End Function
' -------------------------------------------------------------------------------------------------------
Private Sub ShowErrorEvent(ByVal cSubName As String)
    Call VBA.MsgBox("Процедура(функция): " + cSubName _
        + VBA.vbNewLine + "Номер ошибки: " + VBA.str(Err.Number) _
        + VBA.vbNewLine + "Источник: " + Err.Source _
        + VBA.vbNewLine + "Описание: " + Err.Description _
        , VBA.vbOKOnly + VBA.vbCritical, "Ошибка в программе")
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Interactive = True
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
End Sub
