VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} SEEK_POP 
   Caption         =   "Отбор"
   ClientHeight    =   4110
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8535
   OleObjectBlob   =   "SEEK_POP.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "SEEK_POP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False











Option Explicit

Public lbMulti As Boolean, lnWhatLoad As Integer, pcCount As Integer, _
pcRetArrayValue As Variant, pcRetArrayText As Variant, pcRetArrayLink As Variant, _
pcRetValue As String, pcRetText As String, pcRetLink As String

Private Sub CBInvert_Click()
Dim i
    For i = 1 To Me.LstFormula.ListItems.count
        Me.LstFormula.ListItems(i).Checked = Not Me.LstFormula.ListItems(i).Checked
    Next
End Sub

Private Sub cbReset_Click()
Dim i
    For i = 1 To Me.LstFormula.ListItems.count
        Me.LstFormula.ListItems(i).Checked = False
    Next
End Sub

Private Sub CmdExit_Click()
    Unload Me
End Sub

Public Sub CmdOk_Click()
Dim RetArrayValue() As String, _
    RetArrayText() As String, _
    RetArrayLink() As String
Dim count As Integer, i As Integer
        
    If lbMulti Then
        count = 0
        For i = 1 To Me.LstFormula.ListItems.count
            If Me.LstFormula.ListItems(i).Checked = True Then
                count = count + 1
            End If
        Next
        If count = 0 Then
                pcRetValue = VBA.Trim(Me.LstFormula.ListItems(Me.LstFormula.SelectedItem.index))
                pcRetText = VBA.Trim(Me.LstFormula.ListItems(Me.LstFormula.SelectedItem.index).SubItems(1))
                pcRetLink = VBA.Trim(Me.LstFormula.ListItems(Me.LstFormula.SelectedItem.index).Tag)
                pcCount = 1 'добавлено 16.12.2000
        Else
            If count = 1 Then
                For i = 1 To Me.LstFormula.ListItems.count
                    If Me.LstFormula.ListItems(i).Checked = True Then
                        pcRetValue = VBA.Trim(Me.LstFormula.ListItems(i).Text)
                        pcRetText = Me.LstFormula.ListItems(i).SubItems(1)
                        pcRetLink = Me.LstFormula.ListItems(i).Tag
'                        count = count + 1
                    End If
                Next
                pcCount = 1
            Else
                ReDim RetArrayValue(count - 1)
                ReDim RetArrayText(count - 1)
                ReDim RetArrayLink(count - 1)
                
                count = 0
                For i = 1 To Me.LstFormula.ListItems.count
                    If Me.LstFormula.ListItems(i).Checked = True Then
                        RetArrayValue(count) = VBA.Trim(Me.LstFormula.ListItems(i).Text)
                        RetArrayText(count) = Me.LstFormula.ListItems(i).SubItems(1)
                        RetArrayLink(count) = Me.LstFormula.ListItems(i).Tag
                        count = count + 1
                    End If
                Next
                pcRetArrayValue = RetArrayValue
                pcRetArrayText = RetArrayText
                pcRetArrayLink = RetArrayLink
                pcCount = count
                pcRetValue = "Отобрано " + VBA.Trim(VBA.str(count)) + " строк(и)"
            End If
        End If
'        RetArrayValue = ""
 '       RetArrayText = Me.LstFormula.SelectedItem.Text
  '      RetArrayLink = Me.LstFormula.SelectedItem.Tag
    Else
        ' Отбираем выбранный Item
        Select Case lnWhatLoad
            Case 2 ' графа - возвращаем порядковый номер графы и наименование
                pcRetValue = VBA.Trim(VBA.str(Me.LstFormula.SelectedItem.index - 1))
                pcRetText = Me.LstFormula.SelectedItem.Text
                pcRetLink = Me.LstFormula.SelectedItem.Tag
            Case 1 ' строка - Код строки
                pcRetValue = VBA.Trim(Me.LstFormula.SelectedItem.Text)
                pcRetText = Me.LstFormula.SelectedItem.SubItems(1)
                pcRetLink = Me.LstFormula.SelectedItem.Tag
            Case 0, 3 ' строка - Раздел
                pcRetValue = VBA.Trim(Me.LstFormula.SelectedItem.Text)
'                pcRetText = Me.LstFormula.SelectedItem.SubItems(1)
                pcRetLink = Me.LstFormula.SelectedItem.Tag
            Case Else ' Значение из справочника
                If Not (Me.LstFormula.SelectedItem Is Nothing) Then
                    pcRetValue = VBA.Trim(Me.LstFormula.SelectedItem.Text)
                    pcRetText = Me.LstFormula.SelectedItem.SubItems(1)
                End If

                'pcRetValue = VBA.Trim(Me.LstFormula.SelectedItem.Text)
        End Select
    End If
    pbFormCancel = True
    Me.Hide
End Sub

Private Sub LstFormula_BeforeLabelEdit(Cancel As Integer)
    Cancel = True
End Sub

Private Sub LstFormula_DblClick()
    Call Me.CmdOk_Click
End Sub

Private Sub LstFormula_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
If KeyCode = 13 Then
    Call Me.CmdOk_Click
End If
End Sub

Private Sub LstFormula_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    Call Me.CmdOk_Click
End If
End Sub

Private Sub LstFormula_ColumnClick(ByVal ColumnHeader As _
  MSComctlLib.ColumnHeader)
  SortListView LstFormula, ColumnHeader
End Sub

Public Sub SortListView(ByVal lvw As MSComctlLib.ListView, _
   ByVal colHdr As MSComctlLib.ColumnHeader)
   
  ' установка режима сортировки для указанной колонки
  lvw.SortKey = colHdr.index - 1
  If Not lvw.Sorted Then lvw.SortOrder = 1
  lvw.Sorted = True
   
  ' изменение сортировки меняется между
  ' "по возрастанию" и "по уменьшению"
  lvw.SortOrder = (1 Xor lvw.SortOrder)
End Sub

Private Sub TxtSearch_Change()
Dim LookItem As ListItem
With Me
    If .TxtSearch.value <> "" Then
        Set LookItem = .LstFormula.FindItem(VBA.Trim(.TxtSearch.value), lvwText, , lvwPartial)
        If Not LookItem Is Nothing Then
            .LstFormula.ListItems(LookItem.key).Selected = True
            .LstFormula.ListItems(LookItem.key).EnsureVisible
            .LstFormula.SetFocus
            .TxtSearch.SetFocus
        End If
    End If
End With

End Sub

Public Sub Form_init()
Dim nCnt As Integer, lnCol1 As Integer, lnCol2 As Integer, lnRow As Long, lnColumn As Long
Dim lcCodeSpr As String, lcNameSpr As String
Dim lcCodeSpr_rus As String, lcNameSpr_rus As String
Dim lSheetsService As Object, lSheetsSeek As Object, lSheetsReport As Object, LookRange As Range
Dim count As Integer, codeStr As String


Set lSheetsService = Sheets("Service")
Set lSheetsSeek = Sheets("SEEK_POP_SQLDATA")
Set lSheetsReport = Sheets(Sheets("Service").Range("B19").Text)

' начало заполнения листа отчета - с какой записи
pnAddress_Row = Sheets("Service").Range("C5")
' - с какой колонки
pnAddress_Col = Sheets("Service").Range("C6")

Select Case lnWhatLoad
        
        Case 0 ' справочник разделов
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Наименование раздела", 400, 0
                .CheckBoxes = lbMulti
                lnColumn = lSheetsService.Range("KRIT_RAZDEL").column
                lnRow = lSheetsService.Range("KRIT_RAZDEL").row
                lSheetsService.Cells(lnRow + 1, lnColumn + 1) = ""
                For nCnt = 1 To lSheetsService.Range("B23")
                    lSheetsService.Cells(lnRow + 1, lnColumn) = nCnt
                    .ListItems.Add nCnt, "_" + VBA.Trim(VBA.str(nCnt)), VBA.Trim(lSheetsService.Cells(lnRow + 3, lnColumn)), 0
                    .ListItems("_" + VBA.Trim(VBA.str(nCnt))).Tag = VBA.Trim(VBA.str(nCnt))
                Next
            End With
            Me.Caption = pcNameApp + Me.Caption + " - Графы"
        
        Case 2 ' справочник граф
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Наименование графы", 400, 0
                .CheckBoxes = lbMulti
                lnColumn = lSheetsService.Range("KRIT_GRAF").column
                lnRow = lSheetsService.Range("KRIT_GRAF").row
                lSheetsService.Cells(lnRow + 1, lnColumn + 1) = ""
                For nCnt = 1 To lSheetsService.Range("A10")
                    lSheetsService.Cells(lnRow + 1, lnColumn) = nCnt
                    .ListItems.Add nCnt, "_" + VBA.Trim(VBA.str(nCnt)), VBA.Trim(lSheetsService.Cells(lnRow + 2, lnColumn)), 0
                    .ListItems("_" + VBA.Trim(VBA.str(nCnt))).Tag = VBA.Trim(VBA.str(nCnt))
                Next
            End With
            Me.Caption = pcNameApp + Me.Caption + " - Графы"
        Case 1 ' справочник строк
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Код строки", 50, 0
                .ColumnHeaders.Add 2, "_2", "Наименование", 400, 0
                .CheckBoxes = lbMulti
                count = 1
                For nCnt = 1 To lSheetsService.Range("A9")
                    codeStr = getCode(nCnt + pnAddress_Row - 1)
                    If codeStr <> "" Then
                        .ListItems.Add count, "_" + VBA.Trim(VBA.str(count)), codeStr, 0 'VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, pnAddress_Col - Sheets("Service").Range(Sheets("Service").Range("E1")))), 0
                        .ListItems("_" + VBA.Trim(VBA.str(count))).SubItems(1) = VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, pnAddress_Col - Sheets("Service").Range("E5")))
                        .ListItems("_" + VBA.Trim(VBA.str(count))).Tag = VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, 1))
                        count = count + 1
                    End If
                Next
            End With
            Me.Caption = pcNameApp + Me.Caption + " - Строки"
            
        Case Else 'Справочники с SQL Server
            ' Определим реквизиты для заполнения ListView
            With lSheetsService
                lnColumn = .Range("KRIT_SPR").column
                lnRow = .Range("KRIT_SPR").row
                .Cells(lnRow + 1, lnColumn) = lnWhatLoad
                If Not VarType(.Cells(lnRow + 4, lnColumn + 1)) = vbError Then
                    lcCodeSpr_rus = .Cells(lnRow + 4, lnColumn + 1)
                    lcNameSpr_rus = .Cells(lnRow + 5, lnColumn + 1)
                    lcCodeSpr = .Cells(lnRow + 4, lnColumn)
                    lcNameSpr = .Cells(lnRow + 5, lnColumn)
                    Me.Caption = pcNameApp + Me.Caption + " - " + VBA.Trim(.Cells(lnRow + 3, lnColumn))
                Else
                    lcCodeSpr_rus = "Значение"
                    lcNameSpr_rus = "Наименование"
                    lcCodeSpr = "VALUE"
                    lcNameSpr = "NAME"
                    Me.Caption = pcNameApp + Me.Caption + " - " + "Справочник"
                End If
                .Cells(lnRow + 1, lnColumn) = ""
            End With
                    
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", lcCodeSpr_rus, 70, 0
                .ColumnHeaders.Add 2, "_2", lcNameSpr_rus, 400, 0
                .CheckBoxes = lbMulti
                Set LookRange = lSheetsSeek.Columns(1).Find("*", lSheetsSeek.Cells(1, 1), , , xlByRows, xlPrevious)
                Set LookRange = lSheetsSeek.Columns(1).Find(What:="", After:=lSheetsSeek.Cells(1, 1), LookIn:=xlFormulas, lookat:=xlWhole, SearchDirection:=xlNext) 'XlSearchOrder:=xlByRows,
                'Set LookRange = lSheetsSeek.Columns(1).Find("*", lSheetsSeek.Cells(65535, 1), , , xlByRows, xlPrevious)
                lnRow = LookRange.row
                If (lnRow > 2) Then
                    Set LookRange = lSheetsSeek.Rows(1).Find(lcCodeSpr, LookIn:=xlFormulas, lookat:=xlWhole)
                    If Not LookRange Is Nothing Then
                        lnCol1 = LookRange.column
                        Set LookRange = lSheetsSeek.Rows(1).Find(lcNameSpr, LookIn:=xlFormulas, lookat:=xlWhole)
                        lnCol2 = LookRange.column
                        For nCnt = 1 To lnRow - 2
                            .ListItems.Add nCnt, "_" + VBA.Trim(VBA.str(nCnt)), VBA.Trim(lSheetsSeek.Cells(nCnt + 1, lnCol1)), 0
                            .ListItems("_" + VBA.Trim(VBA.str(nCnt))).SubItems(1) = VBA.Trim(lSheetsSeek.Cells(nCnt + 1, lnCol2))
                        Next
                    End If
                End If
                lSheetsSeek.Range("1:" + VBA.Trim(VBA.str(lnRow))).Clear
            End With
End Select
If Not lbMulti Then
    Me.cbInvert.Visible = False
    Me.cbReset.Visible = False
End If
End Sub

Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim lcValuePress As String
Dim LookItem As ListItem

If KeyCode <> 13 And KeyCode <> 27 Then
lcValuePress = Chr(KeyCode)
Me.TxtSearch.value = Me.TxtSearch.value + lcValuePress
    If VBA.Len(Me.TxtSearch.value) <> 0 Then
        Me.TxtSearch.value = VBA.Left(Me.TxtSearch.value, VBA.Len(Me.TxtSearch.value) - 1)
        With Me
            If .TxtSearch.value <> "" Then
                Set LookItem = .LstFormula.FindItem(VBA.Trim(.TxtSearch.value), lvwText, , lvwPartial)
                If Not LookItem Is Nothing Then
                    .LstFormula.ListItems(LookItem.key).Selected = True
                    .LstFormula.ListItems(LookItem.key).EnsureVisible
                End If
            End If
        End With
    End If
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 1 Or CloseMode = 0 Then
    pbFormCancel = False
End If
End Sub

' Загрузка данных из произвольной книги
' lnWhatLoad = 3 -загрузка разделов
' lnWhatLoad = 2 -загрузка граф
' lnWhatLoad = 1 -загрузка кодов строк

Public Sub Form_Init_New(sRazdel As String)
Dim nCnt As Integer, lnCol1 As Integer, lnCol2 As Integer, lnRow As Long, lnColumn As Long
Dim lcCodeSpr As String, lcNameSpr As String
Dim lcCodeSpr_rus As String, lcNameSpr_rus As String
Dim lSheetsService As Object, lSheetsSeek As Object, lSheetsReport As Object, LookRange As Range
Dim count As Integer, codeStr As String, wBook As Workbook
Dim S_RAZDEL_ROW, S_RAZDEL_COLUMNCOUNT, S_RAZDEL_COLUMN, pnAddress_Row, pnAddress_Col, i As Integer, j As Integer, oldRep As Object

Set wBook = Workbooks(Sheets("Service").Range("A14").Text)
Set lSheetsService = wBook.Sheets("Service")
'Set lSheetsReport = Sheets(Sheets("Service").Range("B19").Text)


Select Case lnWhatLoad
    
        Case 0, 3 ' справочник разделов
        With lSheetsService
            S_RAZDEL_ROW = .Range("S_RAZDEL").row
            S_RAZDEL_COLUMN = .Range("S_RAZDEL").column
            S_RAZDEL_COLUMNCOUNT = .Range("S_RAZDEL").Columns.count
            '.Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
            i = S_RAZDEL_ROW + 1
            j = 1
        End With
        If lSheetsService.Range("B23") <> 1 Then
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Наименование раздела", 400, 0
                '.CheckBoxes = lbMulti
                While lSheetsService.Cells(i, S_RAZDEL_COLUMN) <> ""
                    .ListItems.Add j, "_" + VBA.Trim(VBA.str(j)), VBA.Trim(lSheetsService.Cells(i, S_RAZDEL_COLUMN + 1)), 0
                    .ListItems("_" + VBA.Trim(VBA.str(j))).Tag = VBA.Trim(VBA.str(j))
                    i = i + 1
                    j = j + 1
                Wend
            End With
            Me.Caption = Me.Caption + " - Разделы"
        Else
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Наименование раздела", 400, 0
                .ListItems.Add 1, "_" + VBA.Trim(VBA.str(1)), VBA.Trim("Отчет"), 0
                .ListItems("_" + VBA.Trim(VBA.str(1))).Tag = VBA.Trim(VBA.str(0))
            End With
            Me.Caption = Me.Caption + " - Разделы"
        End If
        
       
        Case 2 ' справочник граф
            Set oldRep = ActiveSheet
            Set lSheetsReport = wBook.Sheets(sRazdel)
            lSheetsReport.Activate
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Наименование графы", 400, 0
                .CheckBoxes = lbMulti
                lnColumn = lSheetsService.Range("KRIT_GRAF").column
                lnRow = lSheetsService.Range("KRIT_GRAF").row
                lSheetsService.Cells(lnRow + 1, lnColumn + 1) = ""
                For nCnt = 1 To lSheetsService.Range("A10")
                    lSheetsService.Cells(lnRow + 1, lnColumn) = nCnt
                    .ListItems.Add nCnt, "_" + VBA.Trim(VBA.str(nCnt)), VBA.Trim(lSheetsService.Cells(lnRow + 2, lnColumn)), 0
                    .ListItems("_" + VBA.Trim(VBA.str(nCnt))).Tag = VBA.Trim(VBA.str(nCnt))
                Next
            End With
            oldRep.Activate
            Me.Caption = Me.Caption + " - Графы"
        Case 1 ' справочник строк
            Set oldRep = ActiveSheet
            Set lSheetsReport = wBook.Sheets(sRazdel)
            lSheetsReport.Activate
            ' начало заполнения листа отчета - с какой записи
            pnAddress_Row = wBook.Sheets("Service").Range("C5")
            ' - с какой колонки
            pnAddress_Col = wBook.Sheets("Service").Range("C6")
            With Me.LstFormula
                .ColumnHeaders.Add 1, "_1", "Код строки", 100, 0
                .ColumnHeaders.Add 2, "_2", "Наименование", 400, 0
                .CheckBoxes = lbMulti
                count = 1
                For nCnt = 1 To lSheetsService.Range("A9")
                    codeStr = getCode(nCnt + pnAddress_Row - 1)
                    If codeStr <> "" Then
                        .ListItems.Add count, "_" + VBA.Trim(VBA.str(count)), codeStr, 0 'VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, pnAddress_Col - Sheets("Service").Range(Sheets("Service").Range("E1")))), 0
                        .ListItems("_" + VBA.Trim(VBA.str(count))).SubItems(1) = VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, pnAddress_Col - Sheets("Service").Range("E5")))
                        .ListItems("_" + VBA.Trim(VBA.str(count))).Tag = VBA.Trim(lSheetsReport.Cells(nCnt + pnAddress_Row - 1, 1))
                        count = count + 1
                    End If
                Next
            End With
            oldRep.Activate
            Me.Caption = Me.Caption + " - Строки"
End Select
If Not lbMulti Then
    Me.cbInvert.Visible = False
    Me.cbReset.Visible = False
End If
End Sub

