VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ALG_EDIT 
   ClientHeight    =   5370
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9075
   OleObjectBlob   =   "ALG_EDIT.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "ALG_EDIT"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Option Explicit

Public pnTypeAlg As Integer ' Тип алгоритма расчета
Public pnLinkStr As Integer ' Link строки
Public pnRowStr As Integer  ' Порядковый номер записи Excel
Public pnColumnStr As Integer ' Порядковый номер колонки Excel
Public pnExistsAlg As Boolean ' Флаг наличия алгоритма расчета
Public pnNumFormula As Integer ' Номер текущей формулы
Public pnVidAlg As Integer ' Вид алгоритма расчета
Public pnNumRazdel As Integer ' Номер раздела
Public pnExistsCond  As Boolean ' Флаг существования алгоритма
Public pnLinkAlg As Long ' Link алгоритма
Public pbErrorExists As Boolean
Public pnZnak As Integer ' Знак выборки
Dim fieldArr() As String, operArr() As String
Public lnTRowCount, lnTRowCount1 As Integer
' -------------------------------------------------------------------------------------------------------
' Процедура добавления условия в список
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub Add_Item_Cond(i As Integer)
Dim lnColumnSpr, lnRowSpr, lnColumnKritSpr, lnRowKritSpr As Integer

On Error GoTo doError

    Load PART_CONDEDIT
    PART_CONDEDIT.pnMode = 0
    PART_CONDEDIT.pnNumRazdel = Me.pnNumRazdel
    pbFormCancel = False
    PART_CONDEDIT.Form_init
    With Sheets("Service").Range("TABLE_SPR")
        lnRowSpr = .row
        lnColumnSpr = .column
    End With
    With Sheets("Service").Range("KRIT_SPR")
        lnRowKritSpr = .row
        lnColumnKritSpr = .column
    End With
    If Not pbFormCancel Then
        PART_CONDEDIT.Show
        If pbFormCancel Then
            ' Запись отредактируемого слагаемого
            'критерий
            Sheets("Service").Cells(lnRowKritSpr + 1, lnColumnKritSpr + 2) = PART_CONDEDIT.CmbNAMEOTB.value
            If i = 1 Then
                TextBox1.Text = TextBox1.Text + " " + PART_CONDEDIT.CmbOper.value + " " + IIf(PART_CONDEDIT.CmbNAMEOTB.value <> "", Sheets("Service").Cells(lnRowKritSpr + 10, lnColumnKritSpr).Text, "") + _
                    " " + PART_CONDEDIT.CmbZnak.value + IIf(PART_CONDEDIT.TxtValue.Text <> "", " """ + PART_CONDEDIT.TxtValue.Text + """", "")
            Else
                TextBox2.Text = TextBox2.Text + " " + PART_CONDEDIT.CmbOper.value + " " + Sheets("Service").Cells(lnRowKritSpr + 10, lnColumnKritSpr).Text + _
                    " " + PART_CONDEDIT.CmbZnak.value + " """ + PART_CONDEDIT.TxtValue.Text + """"
            End If
            Unload PART_CONDEDIT
            Me.CmdReset.Enabled = True
            Me.CmdSAVE.Enabled = True
            Me.CmdShablon.Enabled = True
        End If
    Else
        Unload PART_CONDEDIT
    End If
Exit Sub
doError:
    Call ERROR_EVENT("Add_Item_Cond")
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура установки Toolbar
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub SET_TOOLBAR(ByVal lnWhat As Integer)

On Error GoTo doError

Select Case lnWhat
    Case 1 ' Для формулы
        Me.TlbCondition.Buttons("B1").Enabled = False
        Me.TlbCondition.Buttons("B2").Enabled = False
        Me.TlbCondition.Buttons("B3").Enabled = False
        Me.TlbCondition.Buttons("B5").Enabled = True
        Me.CmdShablon.Enabled = False
    Case 2  ' Для условия
        Me.TlbCondition.Buttons("B1").Enabled = True
        Me.TlbCondition.Buttons("B2").Enabled = True 'Not (Me.TextBox1.Text = "" And Me.TextBox2.Text = "")
        Me.TlbCondition.Buttons("B3").Enabled = True 'Not (Me.TextBox1.Text = "" And Me.TextBox2.Text = "")
        Me.TlbCondition.Buttons("B5").Enabled = False
'        Me.CmdTest.Enabled = Not (Me.LstOtbor.ListItems.Count = 0)
        Me.CmdShablon.Enabled = True
End Select

Exit Sub
doError:
    Call ERROR_EVENT("SET_TOOLBAR")
End Sub
' -------------------------------------------------------------------------------------------------------
' Enabled условия отбора
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub Cond_Enabled(b As Boolean)

On Error GoTo doError

    If Not b Then
        TextBox1.BackColor = RGB(128, 128, 128)
        TextBox2.BackColor = RGB(128, 128, 128)
        CmbItogZNAK.BackColor = RGB(128, 128, 128)
    Else
        TextBox1.BackColor = RGB(255, 255, 255)
        TextBox2.BackColor = RGB(255, 255, 255)
        CmbItogZNAK.BackColor = RGB(255, 255, 255)
    End If
    CmbItogZNAK.Enabled = b
    TextBox1.Enabled = b
    TextBox2.Enabled = b
    'OB1.Enabled = b
    'OB2.Enabled = b
    CmdADD.Enabled = b
    CmdADD1.Enabled = b
    CmdTest.Enabled = b
    CmdShablon.Enabled = b

Exit Sub
doError:
    Call ERROR_EVENT("Cond_Enabled")
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура инициализации формы
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub Form_init()
Dim lnColumn As Long, lnRow As Long, lnLinkBar As Long, lnLinkGraf As Long, lnColumnCount As Long

On Error GoTo doError

With Me.TlbCondition
    .ImageList = Me.ImageList1
    .Buttons("B1").Image = 1
    .Buttons("B2").Image = 1
    .Buttons("B3").Image = 2
    .Buttons("B5").Image = 5
    .Buttons("B7").Image = 4
End With

Me.pnExistsAlg = True
' Шапка формы
Me.TxtNameStr.value = Sheets(Sheets("Service").Range("B19").Text).Cells(Me.pnRowStr, pnAddress_Col - Sheets("Service").Range("E5"))
Me.pnNumRazdel = Sheets(Sheets("Service").Range("B19").Text).Cells(Me.pnRowStr, pnAddress_Col - Sheets("Service").Range("E3"))
With Sheets("Service")
    lnColumn = .Range("KRIT_GRAF").column
    lnRow = .Range("KRIT_GRAF").row
    .Cells(lnRow + 1, lnColumn + 1) = ""
    .Cells(lnRow + 1, lnColumn) = Me.pnColumnStr - pnAddress_Col + 1
    Me.TxtNameGraf.value = .Cells(lnRow + 2, lnColumn)
    .Cells(lnRow + 1, lnColumn) = ""
End With
' Определим тип расчета
Select Case pnTypeAlg
    Case 1 'Строки
        Me.Caption = "Ввод/редактирование алгоритма расчета для " + "строки"
        lnLinkBar = pnLinkStr
        lnLinkGraf = 0
    Case 2
        Me.Caption = "Ввод/редактирование алгоритма расчета для " + "ячейки"
        lnLinkBar = pnLinkStr
        lnLinkGraf = Me.pnColumnStr - pnAddress_Col + 1
    Case 3
        Me.Caption = "Ввод/редактирование алгоритма расчета для " + "графы"
        lnLinkBar = -1
        lnLinkGraf = Me.pnColumnStr - pnAddress_Col + 1
End Select
      
Me.CmbItogZNAK.value = IIf(Sheets("Service").Range("B23") = 1, "1", Sheets("Service").Range("B20").Text)
' Вытащить  с TABLE_ALG для строки , если есть
With Sheets("ALG")
    lnColumn = .Range("KRIT_ALG").column
    lnColumnCount = .Range("KRIT_ALG").Columns.count
    lnRow = .Range("KRIT_ALG").row
    ' Сброс критерия поиска
    .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 2)) = ""
    
    .Cells(lnRow + 1, lnColumn) = lnLinkBar
    .Cells(lnRow + 1, lnColumn + 1) = lnLinkGraf
    
    ' Проверим , а есть ли такой алгоритм расчета
    If .Cells(lnRow + 2, lnColumn + 1) = 0 And .Cells(lnRow + 2, lnColumn + 2) = 0 Then ' Запись есть
        pnVidAlg = .Cells(lnRow + 2, lnColumn)
        If pnVidAlg = 1 Then 'Расчет по условию
            Me.OptionButton2.value = 1
            Cond_Enabled (True)
            pnZnak = .Cells(lnRow + 5, lnColumn)
        Else ' Расчет по формуле контроля
            Me.OptionButton1.value = 1
            Me.CmdFormula.Enabled = True
            .Cells(lnRow + 1, lnColumn + 2) = ""
            Me.TxtNumFormula = VBA.Trim(VBA.str(.Cells(lnRow + 3, lnColumn)))
            pnNumFormula = VBA.Val(Me.TxtNumFormula)

        End If
        ' Процедура заполнения условия выборки
        Call CREATE_COND_CONTENTS(lnLinkBar, lnLinkGraf, pnZnak)

    Else ' Нет в базе алгоритма расчета
        Me.OptionButton1.value = 1
        Me.CmdFormula.Enabled = True
        Cond_Enabled (False)
        
        pnExistsAlg = False
    End If
    ' Сброс критерия поиска
    .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 2)) = ""
End With
With Me
    If .pnExistsAlg Then ' Алгоритм существует
        .CmdReset.Enabled = True
    End If
    If .OptionButton1.value = True Then SET_TOOLBAR (1) Else SET_TOOLBAR (2)
    .CmdSAVE.Enabled = False
    .Caption = pcNameApp + .Caption
End With
Exit Sub
doError:
    Call ERROR_EVENT("ALG_EDIT.Form_init")
End Sub

Private Sub CmbItogZNAK_Change()

End Sub

Private Sub CmdADD_Click()
    Call Add_Item_Cond(1)
End Sub

Private Sub CmdADD1_Click()
    Call Add_Item_Cond(2)
End Sub

Private Sub CmdExit_Click()
    Unload Me
End Sub

Public Sub CmdFormula_Click()

On Error GoTo doError

    Load LIST_FORMULA
    LIST_FORMULA.pnMode = 1
    If pnTypeAlg = 3 Then
        LIST_FORMULA.grafControl = True
    End If
    LIST_FORMULA.pnTypeOnly = IIf(pnTypeAlg = 1, 1, IIf(pnTypeAlg = 2, 2, 4))
    LIST_FORMULA.Form_init
    LIST_FORMULA.modifyBaseCode = False
    LIST_FORMULA.Show
    If pbFormCancel Then
        Me.TxtNumFormula = LIST_FORMULA.LstFormula.SelectedItem.Text
        Unload LIST_FORMULA
    End If
    If Not Me.TxtNumFormula = "" Then
        Me.CmdReset.Enabled = True
        Me.CmdSAVE.Enabled = True
    End If

Exit Sub
doError:
    Call ERROR_EVENT("ALG_EDIT.CmdFormula_Click")
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура Сброса алгоритма расчета
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Private Sub CmdReset_Click()
With Me
    Call OptionButton1_Click
    .OptionButton1.value = 1
    .CmdReset.Enabled = False
    .TxtNumFormula.value = ""
    .TextBox1.Text = ""
    .TextBox2.Text = ""
    Me.CmdSAVE.Enabled = True
End With
End Sub
' -------------------------------------------------------------------------------------------------------
' Сохранение алгоритма расчета
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Private Sub CmdSAVE_Click()
Dim lnLinkStr, lnLinkGraf As Integer
Dim lnColumn, lnColumnCount, lnRowUpdate, lnRes As Long
Dim LookRange  As Range
Dim lcExcelTextFormula1, lcExcelTextFormula2 As String
Dim flg1, flg2 As Boolean

    On Error GoTo doError
    ' Определим тип расчета
    Select Case Me.pnTypeAlg
    Case 1
        lnLinkStr = Me.pnLinkStr
        lnLinkGraf = 0
    Case 2
        lnLinkStr = Me.pnLinkStr
        lnLinkGraf = Me.pnColumnStr - pnAddress_Col + 1
    Case 3
        lnLinkStr = -1
        lnLinkGraf = Me.pnColumnStr - pnAddress_Col + 1
    End Select
    ' Сброс алгоритма расчета
    If ALG_EDIT.TxtNumFormula = "" And (Me.TextBox1.Text = "") And (Me.TextBox2.Text = "") Then
        ' Это значит удалить из TABLE_ALG и TABLE_STR_COND и TABLE_PART_COND
        If Me.pnExistsCond Then
            ' Удаляем из TABLE_STR_COND
            lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, Me.pnLinkAlg, 3, "", "", 0, Me.TextBox1.Text, Me.TextBox2.Text)
        End If
        ' Удаляем из TABLE_ALG
        Call WORK_TABLE_ALG(lnLinkStr, lnLinkGraf, Me.pnNumFormula, "", Me.pnVidAlg, 3)
        GoTo End_sub
    End If
    ' Посмотрим , что сохраняем
    If Me.OptionButton1.value = True Then ' расчет по формуле
        If pnExistsAlg Then ' Update алгоритм расчета
            Call WORK_TABLE_ALG(lnLinkStr, lnLinkGraf, Me.pnNumFormula, VBA.Trim(VBA.str(Me.TxtNumFormula)), Me.pnVidAlg, 2)
        Else ' Insert
            Call WORK_TABLE_ALG(lnLinkStr, lnLinkGraf, Me.pnNumFormula, VBA.Trim(VBA.str(Me.TxtNumFormula)), Me.pnVidAlg, 1)
        End If
        ' Запрос на сохранение УСЛОВИЯ!!! алгоритма расчета
        If pnExistsCond Then
            If MsgBox("Сохранить изменения в расчете по условию?", vbYesNo + vbQuestion, "Внимание") = 6 Then
                ' Необходимо проверить условия  и перевести их в форма Excel
                flg1 = TEST_COND_NEW(Me.TextBox1.Text)
                flg2 = True
                If Me.TextBox2.Text <> "" Then
                    flg2 = TEST_COND_NEW(Me.TextBox2.Text)
                End If
                If flg1 And flg2 Then ' Условие правильное
                    If Me.TextBox1.Text = "" Then
                        lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 3, "", "", 0, Me.TextBox1.Text, Me.TextBox2.Text) ' Удаление из TABLE_STR_COND
                    Else
                        lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 2, "", "", Me.CmbItogZNAK.value, Me.TextBox1.Text, Me.TextBox2.Text) ' Update Excel формула
                    End If
                Else
                    MsgBox "Ошибка в условии отбора ! Сохранение невозможно !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
                End If
            End If
        Else
            If Me.TextBox1.Text <> "" Then
                If MsgBox("Сохранить расчет по условию?", vbYesNo + vbQuestion, pcNameApp + "Внимание") = 6 Then
                    ' Необходимо проверить условия  и перевести их в форма Excel
                    flg1 = TEST_COND_NEW(Me.TextBox1.Text)
                    flg2 = True
                    If Me.TextBox2.Text <> "" Then
                        flg2 = TEST_COND_NEW(Me.TextBox2.Text)
                    End If
                    If flg1 And flg2 Then ' Условие правильное
                        lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 1, "", "", CmbItogZNAK.value, Me.TextBox1.Text, Me.TextBox2.Text) ' Вставка в TABLE_STR_COND
'                        Call WORK_TABLE_PART_COND(lnRes, 1, Me.LstOtbor) ' Вставка в TABLE_PART_COND
                    Else
                        MsgBox "Ошибка в условии отбора ! Сохранение невозможно !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
                    End If
                End If
            End If
        End If
Else ' Сохраняем расчет по условиям отбора
    If pnExistsAlg Then ' Update алгоритм расчета
        ' Необходимо проверить условия  и перевести их в форма Excel
        flg1 = TEST_COND_NEW(Me.TextBox1.Text)
        flg2 = True
        If Me.TextBox2.Text <> "" Then
            flg2 = TEST_COND_NEW(Me.TextBox2.Text)
        End If
        If flg1 And flg2 Then ' Условие правильное
            Call WORK_TABLE_ALG(lnLinkStr, lnLinkGraf, Me.pnNumFormula, "", Me.pnVidAlg, 2) ' Update в TABLE_STR_COND
            If pnExistsCond Then
                lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 2, "", "", CmbItogZNAK.value, Me.TextBox1.Text, Me.TextBox2.Text)  ' Update Excel формула
            Else
                lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 1, "", "", CmbItogZNAK.value, Me.TextBox1.Text, Me.TextBox2.Text)  ' Вставка в TABLE_STR_COND
            End If
        Else
            MsgBox "Ошибка в условии отбора ! Сохранение невозможно !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
            Exit Sub
        End If
    Else ' Insert
        ' Необходимо проверить условия  и перевести их в форма Excel
        flg1 = TEST_COND_NEW(Me.TextBox1.Text)
        flg2 = True
        If Me.TextBox2.Text <> "" Then
            flg2 = TEST_COND_NEW(Me.TextBox2.Text)
        End If
        If flg1 And flg2 Then ' Условие правильное
            Call WORK_TABLE_ALG(lnLinkStr, lnLinkGraf, Me.pnNumFormula, "", Me.pnVidAlg, 1) ' Insert в TABLE_ALG
            lnRes = WORK_TABLE_STR_COND(lnLinkStr, lnLinkGraf, pnLinkAlg, 1, "", "", CmbItogZNAK.value, Me.TextBox1.Text, Me.TextBox2.Text)  ' Вставка в TABLE_STR_COND
'            Call WORK_TABLE_PART_COND(lnRes, 1, Me.LstOtbor) ' Вставка в TABLE_PART_COND
        Else
            MsgBox "Ошибка в условии отбора ! Сохранение невозможно !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
        End If
    End If
End If
End_sub:
pbFormCancel = True
Me.Hide

Exit Sub
doError:
    Call ERROR_EVENT("ALG_EDIT.CmdSAVE_Click")
End Sub
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Private Sub CmdShablon_Click()
Dim lnColumn As Long, lnRow As Long, Razdel As Integer

On Error GoTo doError

    With Sheets("Service")
        lnColumn = .Range("SHABLON").column
        lnRow = .Range("SHABLON").row
    End With
    Razdel = Sheets(Sheets("Service").Range("B19").Text).Cells(Application.ActiveCell.row, 2)
    While Sheets("Service").Cells(lnRow, lnColumn) <> ""
        If Sheets("Service").Cells(lnRow, lnColumn) = Razdel Then
            If Sheets("Service").Cells(lnRow, lnColumn + 2).Text = "" Then
                    Me.TextBox1.Text = Me.TextBox1.Text + " " + Sheets("Service").Cells(lnRow, lnColumn + 1).Text
            Else
                    Me.TextBox1.Text = Me.TextBox1.Text + " " + Sheets("Service").Cells(lnRow, lnColumn + 1).Text
                    Me.TextBox2.Text = Me.TextBox2.Text + " " + Sheets("Service").Cells(lnRow, lnColumn + 2).Text
            End If
        End If
        lnRow = lnRow + 1

    Wend

Exit Sub
doError:
    Call ERROR_EVENT("CmdShablon_Click")
End Sub
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Private Sub CmdTest_Click()
Dim lbRet As Boolean

On Error GoTo doError

    lbRet = TEST_COND_NEW(Me.TextBox1.Text)
    If (lbRet = False) Then
        If VBA.Trim(Me.TextBox1.Text) = "" Then
            MsgBox "Ошибка в условии отбора общей выборки! Условие не может быть пустым!", vbCritical + vbOKOnly, pcNameApp + "Внимание"
        Else
            MsgBox "Ошибка в условии отбора общей выборки!", vbCritical + vbOKOnly, pcNameApp + "Внимание"
        End If
    Else
        lbRet = TEST_COND_NEW(Me.TextBox2.Text) Or (VBA.Trim(TextBox2.Text) = "")
        If lbRet = False Then
            MsgBox "Ошибка в условии отбора данных без смены знака!", vbCritical + vbOKOnly, pcNameApp + "Внимание"
        Else
            MsgBox "Условия отбора заполнены правильно !", vbInformation + vbOKOnly, pcNameApp + "Внимание"
        End If
    End If
Exit Sub
doError:
    Call ERROR_EVENT("CmdTest_Click")
End Sub
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function TEST_COND_NEW(ByVal str As String) As Variant
Dim lcCond_Str, lcRet, lcCommand, сSql As String
Dim lbRet As Boolean
Dim nCnt As Long
Dim row, col, rowCount, i As Integer
Dim oRecordSet As Object
Dim LookRange As Range
    
    'соединимся с сервером
    On Error Resume Next
    If oAdoConnect Is Nothing Then
        init_template.cSrv = VBA.Trim(Sheets("Service").Range("A3").value)
        init_template.cUser = VBA.Trim(Sheets("Service").Range("A5").value)
        init_template.cPwd = decode_psw(VBA.Trim(Sheets("Service").Range("A6").value))
        init_template.cDb = VBA.Trim(Sheets("Service").Range("A4").value)
        init_template.nNtUser = VBA.Val(VBA.Trim(Sheets("Service").Range("A22").value))
        Call AdoSrvConnect
    End If
    row = Sheets("Service").Range("TABLE_SPR").row + 1
    col = Sheets("Service").Range("TABLE_SPR").column + 10
    rowCount = Sheets("Service").Range("TABLE_SPR").Rows.count - 1
    lcCommand = "CREATE TABLE #TEST_COND ("
    For i = 0 To rowCount - 1
        If VBA.Trim(Sheets("Service").Cells(row + i, col).Text) <> "" Then lcCommand = lcCommand + VBA.Trim(Sheets("Service").Cells(row + i, col).Text) + " varchar (10), "
    Next
    lcCommand = lcCommand + "FUCK int )"
    ' выполнение запроса на Server
    сSql = "SELECT * FROM #TEST_COND WHERE " + Replace_in_Str(Replace_in_Str(str, """", "'"), "ТОЧНО", "=") + " DROP TABLE #TEST_COND"
    
    Set oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open lcCommand + " " + сSql, oAdoConnect, 2, 1, 1
    If err = 0 Then
        TEST_COND_NEW = True
    Else
        TEST_COND_NEW = False
        oAdoConnect.Execute (" DROP TABLE #TEST_COND ")
    End If
    oRecordSet.Close
    Set oRecordSet = Nothing
    On Error GoTo 0
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function TEST_COND(ByVal str As String) As Variant
Dim lcCond_Str As String
Dim lcRet As String
Dim lbRet As Boolean

On Error GoTo doError

lcCond_Str = FORM_COND_TEMP_STR(str)
lcRet = FORM_COND_EXCEL(lcCond_Str)
If lcRet = "" Then ' Ошибка в формуле
    lbRet = False
Else
    lbRet = CHECK_COND_SYNTAX(lcRet)
End If
If Not lbRet Then
    If lbMode Then
        'MsgBox "Ошибка в условии отбора !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
    Else
        MsgBox "Ошибка в условии отбора ! Сохранение невозможно !", vbCritical + vbOKOnly, pcNameApp + "Внимание"
    End If
    TEST_COND = IIf(lbMode, False, "")
Else
    If lbMode Then
        'MsgBox "Условия отбора заполнены правильно !", vbInformation + vbOKOnly, pcNameApp + "Внимание"
    End If
    TEST_COND = IIf(lbMode, True, lcRet)
End If

Exit Function
doError:
    Call ERROR_EVENT("TEST_COND")
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура формирования промежуточной строки для условий отбора
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function FORM_COND_TEMP_STR(baseStr As String) As String
Dim lnColumn As Integer, lnColumnCount As Integer, lnRow As Integer
Dim lnColumn1 As Integer, lnColumnCount1 As Integer, lnRow1 As Integer, lnLink As Long
Dim lnTColumn1 As Integer, lnTColumnCount1 As Integer, lnTRow1 As Integer
Dim lnTColumn As Integer, lnTColumnCount As Integer, lnTRow As Integer
Dim lcLetter As String, lcTemplate As String, lcTextFormula As String
Dim lSheetsService As Object
Dim nCnt As Integer, lcValue As String, oper As Integer
Dim str As String, field As String, znak As String, value As String
Dim i As Integer

lcTextFormula = ""

Set lSheetsService = Sheets("Service")
On Error GoTo err
With lSheetsService
    lnColumn = .Range("KRIT_SHABLON_COND").column
    lnColumnCount = .Range("KRIT_SHABLON_COND").Columns.count
    lnRow = .Range("KRIT_SHABLON_COND").row
    lnColumn1 = .Range("KRIT_SPR").column
    lnColumnCount1 = .Range("KRIT_SPR").Columns.count
    lnRow1 = .Range("KRIT_SPR").row
    
    lnTColumn = .Range("TABLE_SHABLON_COND").column
    lnTRowCount = .Range("TABLE_SHABLON_COND").Rows.count
    lnTRow = .Range("TABLE_SHABLON_COND").row
    lnTColumn1 = .Range("TABLE_SPR").column
    lnTRowCount1 = .Range("TABLE_SPR").Rows.count
    lnTRow1 = .Range("TABLE_SPR").row

End With

ReDim fieldArr(2, lnTRowCount1 - 1)
ReDim operArr(lnTRowCount - 1)
For i = 1 To lnTRowCount1 - 1
    fieldArr(0, i - 1) = lSheetsService.Cells(lnTRow1 + i, lnTColumn1 + 10)
    fieldArr(1, i - 1) = lSheetsService.Cells(lnTRow1 + i, lnTColumn1 + 8)
Next
For i = 1 To lnTRowCount - 1
    operArr(i - 1) = lSheetsService.Cells(lnTRow + i, lnTColumn + 2)
Next
str = VBA.Trim(baseStr)
While nextCom(str, field, znak, value)
    ' Определим что за объект
    If field = "" Then ' Знаки
        ' Определим Link знака
        lcValue = znak
        ' Заполним критерий отбора
        lSheetsService.Cells(lnRow + 1, lnColumn + 2) = """" + lcValue + """"
        ' Считаем LInk
        lnLink = lSheetsService.Cells(lnRow + 5, lnColumn)
        lcTextFormula = lcTextFormula + VBA.Trim(VBA.str((lnLink))) + "#"
    Else ' Условия со значением
        ' Определим LINK знака
        lcValue = znak
        ' Заполним критерий отбора для знака
        lSheetsService.Cells(lnRow + 1, lnColumn + 2) = """" + lcValue + """"
        ' Считаем Link
        lnLink = lSheetsService.Cells(lnRow + 5, lnColumn)
        oper = lSheetsService.Cells(lnRow + 6, lnColumn).value
        ' Считаем шаблон условия
        lcTemplate = lSheetsService.Cells(lnRow + 2, lnColumn)
        ' Заполним критерий отбора для поля
        lcValue = field
        'lSheetsService.Cells(lnRow1 + 1, lnColumn1 + 2) = lcValue
        'Считаем адрес поля условия
        lcLetter = lcValue 'lSheetsService.Cells(lnRow1 + 6, lnColumn1)
        ' Заменим в шаблоне '%t' на адрес
        lcTemplate = Replace_in_Str(lcTemplate, "%t", lcLetter)
        If oper = 1 Then
            lcValue = TRUNCATE_00(value)
            lcValue = Replace_in_Str(lcValue, "&", "")
        Else
            lcValue = value
        End If
        ' Заменим в шаблоне '%s' на значение
        lcTemplate = Replace_in_Str(lcTemplate, "%s", lcValue)
        lcTextFormula = lcTextFormula + lcTemplate + "#"
        
    End If
Wend
'Next
FORM_COND_TEMP_STR = lcTextFormula
Exit Function
err:
    FORM_COND_TEMP_STR = ""
End Function
' Функция проверки синтаксиса функции
Public Function CHECK_COND_SYNTAX(ByVal lcTextFormula As String) As Boolean
Dim lcFormula As String

lcFormula = "=" + lcTextFormula
' Поставим в ячейку
On Error Resume Next
Sheets("SQLData1").Range("O2").FormulaLocal = lcFormula
If err.Number <> 0 Then
    On Error GoTo 0
    CHECK_COND_SYNTAX = False
    Exit Function
End If
CHECK_COND_SYNTAX = True
Sheets("SQLData1").Range("O2").FormulaLocal = ""
End Function
' Функция формирования условия в формате Excel
Public Function FORM_COND_EXCEL(ByVal Expr As String) As String

Dim lcText As String
Dim lcChar1 As String, lcChar2 As String, lcChar3 As String
Dim lnStart2 As Integer, lnStart1 As Integer
Dim lcS1 As String, lcS2 As String
Dim lcPos As String, lcCharOst As String, lcNotInsert As String
Dim lnPosOper As Integer

On Error GoTo doError

lcText = Expr
If lcText = "" Then
    FORM_COND_EXCEL = "" ' Ошибка
    Exit Function
End If
' Возьмем первое значение
lnStart1 = VBA.InStr(1, lcText, "#", vbTextCompare)
lcChar1 = VBA.Mid(lcText, 1, lnStart1 - 1)

Select Case VBA.Val(lcChar1)
    Case 4 ' Скобка "("
            ' Определим выражение для рекурсии
            ' Определим позицию lnOc закрывающейся скобки
            lcPos = OccurInStop(lcText, "4#", "5#")
            If lcPos = 0 Then ' Нет закрывающейся скобки
                FORM_COND_EXCEL = ""
                Exit Function
            End If
            ' Вырезаем выражение
            lcChar1 = VBA.Mid(lcText, 3, lcPos - 3)
            lcS1 = lcChar1 ' Занесем в стек

            'Смотрим след символ (Должен быть операнд)
            lcChar1 = FORM_COND_EXCEL(lcChar1)
            If lcChar1 = "" Then
                FORM_COND_EXCEL = ""
                Exit Function
            End If
            
            lcCharOst = VBA.Mid(lcText, 3 + lcPos - 1)
            If lcCharOst = "" Then
                FORM_COND_EXCEL = lcChar1
                Exit Function
            Else
                lnPosOper = VBA.InStr(1, lcCharOst, "#", vbTextCompare)
                lcChar2 = VBA.Mid(lcCharOst, 1, lnPosOper - 1)
                If VBA.Val(lcChar2) <> 6 And VBA.Val(lcChar2) <> 7 Then ' Не операнд - ошибка
                    FORM_COND_EXCEL = ""
                Exit Function
            End If
                
                lcS2 = lcChar2 ' Занесем операнд в стек
                ' Вырежим остальное выражение
                lcChar3 = VBA.Mid(lcCharOst, lnPosOper + 1)
                lcChar3 = FORM_COND_EXCEL(lcChar3)
                If lcChar3 = "" Then
                    FORM_COND_EXCEL = ""
                    Exit Function
                End If

                Select Case VBA.Val(lcS2)
                    Case 7 'ИЛИ
                        FORM_COND_EXCEL = "ИЛИ(" + lcChar1 + ";" + lcChar3 + ")"
                    Case 6 'И
                        FORM_COND_EXCEL = "И(" + lcChar1 + ";" + lcChar3 + ")"
                End Select
                Exit Function
            End If
            
    Case 8 ' Функция НЕ
        ' После функции смотрим след символ (должна быть скобка)
        lnStart2 = VBA.InStr(lnStart1 + 1, lcText, "#", vbTextCompare)
        lcChar2 = VBA.Mid(lcText, lnStart1 + 1, lnStart2 - lnStart1 - 1)
        lcText = VBA.Mid(lcText, 3)
        If VBA.Val(lcChar2) = 4 Then
            ' Определим выражение для рекурсии
            ' Определим позицию lnOc закрывающейся скобки
            lcPos = OccurInStop(lcText, "4#", "5#")
            ' Вырезаем выражение
            lcChar1 = VBA.Mid(lcText, 3, lcPos - 3)
            lcS1 = lcChar1 ' Занесем в стек

            'Смотрим след символ (Должен быть операнд)
            lcChar1 = FORM_COND_EXCEL(lcChar1)
            If lcChar1 = "" Then
                FORM_COND_EXCEL = ""
                Exit Function
            End If

            lcCharOst = VBA.Mid(lcText, 3 + lcPos - 1)
            If lcCharOst = "" Then
                lcNotInsert = lcChar1
            Else
                lnPosOper = VBA.InStr(1, lcCharOst, "#", vbTextCompare)
                lcChar2 = VBA.Mid(lcCharOst, 1, lnPosOper - 1)
                lcS2 = lcChar2 ' Занесем операнд в стек
                ' Вырежим остальное выражение
                lcChar3 = VBA.Mid(lcCharOst, lnPosOper + 1)
                lcChar3 = FORM_COND_EXCEL(lcChar3)
                If lcChar3 = "" Then
                    FORM_COND_EXCEL = ""
                    Exit Function
                End If
                Select Case VBA.Val(lcS2)
                    Case 7 'ИЛИ
                        lcNotInsert = "ИЛИ(" + lcChar1 + ";" + lcChar3 + ")"
                    Case 6 'И
                        lcNotInsert = "И(" + lcChar1 + ";" + lcChar3 + ")"
                End Select
            End If
            FORM_COND_EXCEL = "НЕ(" + lcChar1 + ")"
            Exit Function
        Else
            'Ошибка в формуле
            FORM_COND_EXCEL = ""
            Exit Function
        End If
    Case Else ' Значение
        'Выцепим шаблон условия
        lcS1 = lcChar1 ' Занесем в стек
        'Посмотрим след. символ должен быть операнд
        lnStart2 = VBA.InStr(lnStart1 + 1, lcText, "#", vbTextCompare)
        
        If lnStart2 = 0 Then ' Больше ничего нет
            FORM_COND_EXCEL = lcS1
            Exit Function
        Else
            lcChar2 = VBA.Mid(lcText, lnStart1 + 1, lnStart2 - lnStart1 - 1)
            If VBA.Val(lcChar2) <> 6 And VBA.Val(lcChar2) <> 7 Then ' Не операнд - ошибка
                FORM_COND_EXCEL = ""
                Exit Function
            End If
            lcS2 = lcChar2 ' Занесем в стек
            'Вырезаем оставшееся выражение
            lcChar3 = VBA.Mid(lcText, lnStart2 + 1)
            'Рекурсивный вызов функции
            lcChar3 = FORM_COND_EXCEL(lcChar3)
            If lcChar3 = "" Then
                FORM_COND_EXCEL = ""
                Exit Function
            End If
            'Стыкуем
            Select Case VBA.Val(lcChar2)
                    Case 7 ' ИЛИ
                        FORM_COND_EXCEL = "ИЛИ(" + lcS1 + ";" + lcChar3 + ")"
                    Case 6 ' И
                        FORM_COND_EXCEL = "И(" + lcS1 + ";" + lcChar3 + ")"
            End Select
            Exit Function
        End If
'    Case Else
'        FORM_COND_EXCEL = lcChar1
    End Select

Exit Function
doError:
    Call ERROR_EVENT("FORM_COND_EXCEL")
End Function

Private Sub CommandButton1_Click()
    Call GetSQLData_SPR("  V_SELECT_SUM_LIST '" + VBA.Trim(Sheets("Service").Range("A15").Text) + "'," + VBA.Trim(VBA.str(Me.pnColumnStr - pnAddress_Col + 1)))
    With SEEK_POP
        Load SEEK_POP
        .lbMulti = False
        .lnWhatLoad = -1
        .Form_init
        .Show
        If pbFormCancel Then
            CmbItogZNAK.value = SEEK_POP.pcRetValue
            Me.CmdSAVE.Enabled = True
        End If
        Unload SEEK_POP
    End With
End Sub

Private Sub Frame1_Click()

End Sub

Private Sub Frame2_Click()

End Sub

Private Sub ImageList1_Enter()

End Sub

Public Sub OptionButton1_Click()
    Me.CmdFormula.Enabled = True
    Cond_Enabled (False)
    Call SET_TOOLBAR(1)
    Me.CmdSAVE.Enabled = Not (Me.TxtNumFormula.value = "")
End Sub
Private Sub OptionButton2_Click()
   
    Me.CmdFormula.Enabled = False
    Cond_Enabled (True)
    Me.CmdShablon.Enabled = True
    Me.CmdSAVE.Enabled = Not (Me.TextBox1.Text = "" And Me.TextBox2.Text = "")
    Call SET_TOOLBAR(2)
End Sub
Private Sub TextBox1_Change()
    If VBA.Trim(TextBox1.Text) <> "" Then
        Me.CmdSAVE.Enabled = True
    Else
        Me.CmdSAVE.Enabled = False
    End If
End Sub

Private Sub TextBox2_Change()
    If VBA.Trim(TextBox1.Text) <> "" Then Me.CmdSAVE.Enabled = True
End Sub

Private Sub TlbCondition_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
    Case "B1"
        Call Add_Item_Cond(1)
    Case "B2"
        Call Add_Item_Cond(2)
    Case "B3"
        Call CmdTest_Click
    Case "B5"
        Call Me.CmdFormula_Click
    Case "B7"
        Unload Me
End Select
End Sub

Private Sub TxtNameStr_Change()

End Sub

Private Sub TxtNumFormula_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Me.TxtNumFormula.Text = "" 'MsgBox (VBA.str(KeyCode))
    Me.CmdSAVE.Enabled = True
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура заполнения условий расчета
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub CREATE_COND_CONTENTS(ByVal lnLinkBar As Integer, ByVal lnLinkGraf As Integer, znak As Integer)
Dim LookRange As Range, lnColumn As Long, lnColumnCount As Long, lnRow As Long
Dim lbNotExit As Boolean, lcValue As String
Dim nCnt As Long, lnFirstAddress As String, lnRow1 As Long

On Error GoTo doError

nCnt = 1
lbNotExit = True
pnExistsCond = True
' Заполним критерий поиска LINK_OTBOR
    With Sheets("OTBOR_COND")
        lnColumn = .Range("KRIT_STR_COND").column
        lnColumnCount = .Range("KRIT_STR_COND").Columns.count
        lnRow = .Range("KRIT_STR_COND").row
        .Cells(lnRow + 1, lnColumn) = lnLinkBar
        .Cells(lnRow + 1, lnColumn + 1) = lnLinkGraf
        
        ' Посмотрим есть ли запись в таблице TABLE_STR_OTB
        If .Cells(lnRow + 2, lnColumn + 1) = 0 And .Cells(lnRow + 2, lnColumn + 2) = 0 Then 'Запись одна
            pnZnak = .Cells(lnRow + 6, lnColumn)
            Me.TextBox1.Text = .Cells(lnRow + 8, lnColumn)
            If .Cells(lnRow + 7, lnColumn + 1) = 0 Then Me.TextBox2.Text = .Cells(lnRow + 9, lnColumn)
            .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 2)) = ""
        Else
            pnExistsCond = False
            .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 2)) = ""
            Exit Sub
        End If
                Me.CmbItogZNAK.value = pnZnak
    End With

Exit Sub
doError:
    Call ERROR_EVENT("CREATE_COND_CONTENTS")
End Sub
Public Function readZnak(str As String, znak As String) As Boolean
Dim i As Integer, s As String, j As Integer

On Error GoTo doError

i = 0
    s = ""
    While (Len(str) > VBA.Len(s))
        i = i + 1
        s = VBA.Left(str, i)
        For j = 0 To lnTRowCount - 1
            If """" + s + """" = operArr(j) Then
                str = VBA.Trim(VBA.Right(str, VBA.Len(str) - i))
                znak = s
                readZnak = True
                GoTo sss
            End If
        Next
    Wend
sss:

Exit Function
doError:
    Call ERROR_EVENT("readZnak")
End Function
Public Function readField(str As String, field As String) As Boolean
Dim i As Integer, s As String, j As Integer

On Error GoTo doError

    i = 0
    s = ""
    While (Len(str) > VBA.Len(s))
        i = i + 1
        s = VBA.Left(str, i)
        For j = 0 To lnTRowCount1 - 1
            If s = fieldArr(0, j) Then
                str = VBA.Trim(Right(str, VBA.Len(str) - i))
                field = fieldArr(1, j)
                readField = True
                GoTo sss
            End If
        Next
    Wend
sss:

Exit Function
doError:
    Call ERROR_EVENT("readField")
End Function

Public Function nextCom(str As String, field As String, znak As String, value As String) As Boolean

On Error GoTo doError

    If readZnak(str, znak) Then
        nextCom = True
        field = ""
    Else
        If readField(str, field) Then
            If Not readZnak(str, znak) Then nextCom = False
            If VBA.Left(str, 1) <> """" Then
                nextCom = False
            Else
                value = VBA.Mid(str, 2, VBA.InStr(2, str, """", vbTextCompare) - 2)
                nextCom = True
                str = VBA.Trim(Right(str, VBA.Len(str) - VBA.Len(value) - 2))
            End If
        Else
            nextCom = False
        End If
    End If

Exit Function
doError:
    Call ERROR_EVENT("nextCom")
End Function

Private Sub UserForm_Click()

End Sub
