Attribute VB_Name = "SQLSERVER_R"
Option Explicit
Public oAdoConnect As Object
Type bkType
    bkCode As String
    bkLink As Integer
End Type
'---------------------------------------------------------------------------------------------------------------
' Функция открытия ADO соединения с SQL сервером
' EdiS\07.10.10\bugs-16042
'---------------------------------------------------------------------------------------------------------------
Function AdoSrvConnect()

    On Error GoTo doError
    Set oAdoConnect = CreateObject("ADODB.Connection")
    If nNtUser = 1 Then ' Win connect
            oAdoConnect.ConnectionString = "Provider=SQLOLEDB;Server=" + cSrv + ";Database=" + cDb + ";Trusted_Connection=yes;"
    Else                ' Sql connect
        oAdoConnect.ConnectionString = "Provider=SQLOLEDB;Server=" + cSrv + ";Database=" + cDb + ";Uid=" + cUser + ";Pwd=" + cPwd
    End If
    oAdoConnect.ConnectionTimeout = 0
    oAdoConnect.CommandTimeout = 0
    oAdoConnect.CursorLocation = 3
    oAdoConnect.mode = 3
    oAdoConnect.Open
    oAdoConnect.Execute "SET LANGUAGE ENGLISH"
    oAdoConnect.Execute "SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED"
    oAdoConnect.Execute "SET QUOTED_IDENTIFIER ON"
    oAdoConnect.Execute "SET ANSI_NULLS ON"
    oAdoConnect.Execute "SET ARITHABORT ON"
    oAdoConnect.Execute "SET CONCAT_NULL_YIELDS_NULL ON"
    oAdoConnect.Execute "SET ANSI_PADDING ON"
    oAdoConnect.Execute "SET ANSI_WARNINGS ON"
    oAdoConnect.Execute "SET NUMERIC_ROUNDABORT OFF"
    oAdoConnect.Execute "SET NOCOUNT ON"
    oAdoConnect.Execute "SET XACT_ABORT ON"
        Exit Function
doError:
    Call AdoSrvDisconnect
    Call ERROR_EVENT("AdoSrvConnect")
End Function
' -------------------------------------------------------------------------------------------------------
' Закрытие ADO соединения с SQL сервером
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub AdoSrvDisconnect()
    
    On Error GoTo doError
    If Not VBA.IsEmpty(oAdoConnect) Then
        If Not oAdoConnect Is Nothing Then
            oAdoConnect.Close
        End If
    End If
    Set oAdoConnect = Nothing
    Exit Sub
doError:
    Call ERROR_EVENT("AdoSrvDisсonnect")
End Sub
'---------------------------------------------------------------------------------------------------------------
' Очищение полей поиска по критерию в SQLData1
'---------------------------------------------------------------------------------------------------------------
Sub CLEAR_KRIT_SQLDATA1()
Dim lnColumn As Long, lnRow As Long, lnColumnCount As Long
With Sheets("SQLData1").Range("KRIT_SQLDATA1")
    lnColumn = .column
    lnRow = .row
    lnColumnCount = .Columns.count
End With
With Sheets("SQLData1")
    .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 1)) = ""
End With
End Sub
'---------------------------------------------------------------------------------------------------------------
' Очищение полей в SQLData1
'---------------------------------------------------------------------------------------------------------------
Sub CLEAR_TABLE_SQLDATA1()
Dim lnColumn As Long, lnRow As Long, lnColumnCount As Long
With Sheets("SQLData1")
    lnColumn = .Range("TABLE_SQLDATA1").column
    lnColumnCount = .Range("TABLE_SQLDATA1").Columns.count
    lnRow = .Range("TABLE_SQLDATA1").row
    ' Очистить содержимое
    .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 1)).ClearContents
End With
End Sub
'---------------------------------------------------------------------------------------------------------------
'???
'---------------------------------------------------------------------------------------------------------------
Public Sub SEEK_POP_GET_DATA(ByVal WhatLoad As Integer, _
                             ByVal MultiSelect As Boolean)
Dim lbMulti As Boolean
Dim lcSQLCommand As String
Dim lnColumn As Long, lnRow As Long, lnColumnCount As Long
    
On Error GoTo doError
    
lbMulti = MultiSelect
If WhatLoad > 2 Then ' Грузим справочники
    'Определим команду выборки
    With Sheets("Service")
        lnColumn = .Range("KRIT_SPR").column
        lnColumnCount = .Range("KRIT_SPR").Columns.count
        lnRow = .Range("KRIT_SPR").row
        .Range(.Cells(lnRow + 1, lnColumn), .Cells(lnRow + 1, lnColumn + lnColumnCount - 1)) = ""
        .Cells(lnRow + 1, lnColumn) = WhatLoad
        lcSQLCommand = .Cells(lnRow + 2, lnColumn)
        .Cells(lnRow + 1, lnColumn) = ""
    End With
    Call GetSQLData_SPR(lcSQLCommand)
End If
With SEEK_POP
    Load SEEK_POP
    .lbMulti = lbMulti
    .lnWhatLoad = WhatLoad
    .Form_init
    .Show
End With

Exit Sub
doError:
    Call ERROR_EVENT("SEEK_POP_GET_DATA")
End Sub
' -------------------------------------------------------------------------------------------------------
' Получение данных из справочников
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub GetSQLData_SPR(ByVal lcCommand As String)
Dim nCnt As Long
Dim oRecordSet As Object
Dim cSql As String, wrkCount
Dim LookRange As Range

    'Иницилизация глобальных переменных
    Call init_data
    On Error GoTo nnn
    If oAdoConnect Is Nothing Then
nnn:
        Call AdoSrvConnect
    End If

    On Error GoTo doError
    cSql = "EXECUTE " + lcCommand
    Set oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
    With Sheets("SEEK_POP_SQLDATA")
        For nCnt = 1 To oRecordSet.Fields.count
            .Cells(1, nCnt) = oRecordSet.Fields(nCnt - 1).name
        Next
        wrkCount = 0
        While Not oRecordSet.EOF
            If wrkCount <> 0 Then oRecordSet.MoveNext
            .Cells(2 + wrkCount * 200, 1).CopyFromRecordset oRecordSet, 200, oRecordSet.Fields.count
            wrkCount = wrkCount + 1
        Wend
    End With
    oRecordSet.Close
    Set oRecordSet = Nothing
Exit Sub
doError:
    Call ERROR_EVENT("GetSQLData_SPR")
End Sub
'---------------------------------------------------------------------------------------------------------------
' Процедура выборки расчетных данных
'---------------------------------------------------------------------------------------------------------------
Sub GetSQLData_CALC()
Dim oRecordSet, SheetsService, SheetsSqlData  As Object
Dim cSql, cSqlEnd As String
Dim nCnt As Long
Dim LookRange As Range
Dim wrkCount As Integer

    On Error GoTo doError
    Set SheetsService = Application.ActiveWorkbook.Sheets("Service")
    Set SheetsSqlData = Application.ActiveWorkbook.Sheets("SqlData1")
    cSqlEnd = " '" + VBA.Trim(pDateBegin) + "'," + "'" + VBA.Trim(pDateEnd) + "'," + VBA.Trim(VBA.str(SheetsService.Range("A28").Value))
    'выполнение запроса на Server
    cSql = SheetsService.Range("A41") + " " + cSqlEnd
    Set oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
    'Почистим старые данные
    Set LookRange = SheetsSqlData.Columns(1).Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
    SheetsSqlData.Range(SheetsSqlData.Cells(2, 1), SheetsSqlData.Cells(LookRange.row, SheetsSqlData.Range("TABLE_SQLDATA1").Columns.count)) = ""
    ' заполнение таблицы с данными
    wrkCount = 0
    While Not oRecordSet.EOF
        If wrkCount <> 0 Then oRecordSet.MoveNext
        SheetsSqlData.Cells(2 + wrkCount * 200, 1).CopyFromRecordset oRecordSet, 200, oRecordSet.Fields.count
        wrkCount = wrkCount + 1
    Wend
    oRecordSet.Close
    Set oRecordSet = Nothing

    Set LookRange = SheetsSqlData.Columns(1).Find("", LookIn:=xlValues, SearchOrder:=xlByRows)
    If Not LookRange Is Nothing Then
        For nCnt = 2 To LookRange.row - 1
            SheetsSqlData.Cells(nCnt, 2).Value = SheetsSqlData.Cells(nCnt, 2).Text
        Next
    End If
    ' установим флаг загрузки выборки для расчета
    SheetsService.Range("A25") = 1
    'вызов GetSQLData_CALC_After
    If VBA.Trim(SheetsService.Range("B36").Text) <> "" Then
        Application.Run (SheetsService.Range("B36").Text)
    End If
Exit Sub
doError:
    Call ERROR_EVENT("GetSQLData_CALC")
End Sub
'---------------------------------------------------------------------------------------------------------------
' Процедура получения и заполнение данными  существующего отчета
' EdiS\07.10.10\bugs-16042
'---------------------------------------------------------------------------------------------------------------
Sub GetSQLData()
Dim oRecordSet As Object
Dim cSql, cSqlEnd As String
Dim SheetsService, sheetsReport As Object
Dim lnRowCount, lnColumn1, lnRow1, wrkCount As Long
Dim i As Integer

    On Error GoTo doError
    Set SheetsService = Sheets("Service")

    With SheetsService.Range("KRIT_RAZDEL")
        lnColumn1 = .column
        lnRow1 = .row
    End With
    For i = 1 To SheetsService.Range("B23")
        ' установим страницу зададим критерий
        SheetsService.Cells(lnRow1 + 1, lnColumn1 + 1) = ""
        SheetsService.Cells(lnRow1 + 1, lnColumn1) = i
        SheetsService.Cells(lnRow1 + 3, lnColumn1).CALCULATE

        If SheetsService.Range("B23") <> 1 Then
            Set sheetsReport = Application.ActiveWorkbook.Sheets(SheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
        Else
            Set sheetsReport = Application.ActiveWorkbook.Sheets(SheetsService.Range("B19").Text)
        End If
        sheetsReport.Activate
        'снять защиту
        sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
        SheetsService.Cells(lnRow1 + 4, lnColumn1).CALCULATE
        Blank = SheetsService.Cells(lnRow1 + 4, lnColumn1).Value
        SheetsService.Cells(lnRow1 + 5, lnColumn1).CALCULATE

        linkRep = IIf(VBA.Trim(SheetsService.Cells(lnRow1 + 5, lnColumn1)) = "", 0, SheetsService.Cells(lnRow1 + 5, lnColumn1).Value)
        If Blank = 0 Then
            sheetsReport.Range("MAIN_DATA") = ""
            If SheetsService.Range("A28") <> 1 Then
                If SheetsService.Range("A28") = 5 Then
                    sheetsReport.Range("MAIN_DATA").NumberFormat = "#,##0.0"
                Else
                    sheetsReport.Range("MAIN_DATA").NumberFormat = "#,##0"
                End If
            End If
            '
            Call writeZeros
            sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
            sheetsReport.Range("MAIN_DATA").Interior.ColorIndex = xlColorIndexNone
            sheetsReport.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
        End If
        SheetsService.Cells(lnRow1 + 1, lnColumn1) = ""
    
        Sheets("SQLData").Cells = ""
        'условия отбора
        cSqlEnd = VBA.Trim(VBA.str(SheetsService.Range("A10"))) + _
                    ",'" + pCodeObject + "'," + _
                    VBA.Trim(VBA.str(pCorr_in)) + "," + _
                    IIf(pnUser = 1, IIf(VBA.Trim(VBA.str(pCorr_out)) = 0, "NULL", VBA.Trim(VBA.str(pCorr_out))), "NULL") + _
                    ",'" + VBA.Trim(pDateBegin) + "'," + _
                    "'" + VBA.Trim(pDateEnd) + "'," + _
                    VBA.Trim(VBA.str(Sheets("Service").Range("A28").Value)) + "," + _
                    IIf(SheetsService.Range("B23") = 1, "0", VBA.str(i)) + "," + _
                    IIf(Blank = 0, "0", "1") + ", " + IIf(VBA.Trim(VBA.str(Sheets("Service").Range("A69").Value)) <> "", VBA.Trim(VBA.str(Sheets("Service").Range("A69").Value)), "0")

        ' выполнение запроса на Server на кол-во записей
        cSql = SheetsService.Range("A40") & " 0," & cSqlEnd
        Set oRecordSet = CreateObject("ADODB.RecordSet")
        oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
        lnRowCount = oRecordSet.Fields("Rec").Value
        oRecordSet.Close
        Set oRecordSet = Nothing
        ' выполнение запроса на Server
        cSql = SheetsService.Range("A40") & " 1," & cSqlEnd
        Set oRecordSet = CreateObject("ADODB.RecordSet")
        oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
        ' заполнение таблицы с данными
        wrkCount = 0
        While Not oRecordSet.EOF
            If wrkCount <> 0 Then oRecordSet.MoveNext
            Sheets("SQLData").Cells(1 + wrkCount * 200, 1).CopyFromRecordset oRecordSet, 200, oRecordSet.Fields.count
            wrkCount = wrkCount + 1
        Wend
        oRecordSet.Close
        Set oRecordSet = Nothing

        ' количество элементов в таблице
        Call SetPageHeight
        Call COPY_DATA(lnRowCount, i)
    Next

    If SheetsService.Range("B23") = 1 And Blank <> 0 Then
    On Error GoTo nnn
        Application.CommandBars("Строка меню отчета").Controls("Бланк").Visible = True
nnn:
    End If
    'поставить защиту
    sheetsReport.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
Exit Sub
doError:
    Call ERROR_EVENT("GetSQLData")
End Sub
'---------------------------------------------------------------------------------------------------------------
' Процедура получения и заполнение данными сводного отчета
' EdiS\07.10.10\bugs-16042
'---------------------------------------------------------------------------------------------------------------
Sub GetSQLData_SVOD()
Dim oRecordSet, SheetsService, SheetsSqlData, sheetsReport As Object
Dim cSql, cSqlEnd As String
Dim lnRowCount As Long
Dim page As Integer
Dim i, lnColumn1, lnRow1, wrkCount As Integer

    On Error GoTo doError
    Set SheetsService = Application.ActiveWorkbook.Sheets("Service")
    Set SheetsSqlData = Application.ActiveWorkbook.Sheets("SqlData")

    With SheetsService.Range("KRIT_RAZDEL")
        lnColumn1 = .column
        lnRow1 = .row
    End With
    For i = 1 To SheetsService.Range("B23")
        'установим страницу зададим критерий
        SheetsService.Cells(lnRow1 + 1, lnColumn1) = i
        SheetsService.Cells(lnRow1 + 3, lnColumn1).CALCULATE
        If SheetsService.Range("B23") <> 1 Then
            Set sheetsReport = Application.ActiveWorkbook.Sheets(SheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
        Else
            Set sheetsReport = Application.ActiveWorkbook.Sheets(SheetsService.Range("B19").Text)
        End If
        sheetsReport.Activate
        'снять защиту
        sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
        SheetsService.Cells(lnRow1 + 4, lnColumn1).CALCULATE
        Blank = SheetsService.Cells(lnRow1 + 4, lnColumn1).Value
        SheetsService.Cells(lnRow1 + 5, lnColumn1).CALCULATE
        'Stop
        linkRep = IIf(VBA.Trim(SheetsService.Cells(lnRow1 + 5, lnColumn1)) = "", 0, SheetsService.Cells(lnRow1 + 5, lnColumn1).Value)
        If Blank = 0 Then
            sheetsReport.Range("MAIN_DATA") = ""
            Call writeZeros
            sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
            sheetsReport.Range("MAIN_DATA").Interior.ColorIndex = xlColorIndexNone
            sheetsReport.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
        End If
        SheetsService.Cells(lnRow1 + 1, lnColumn1) = ""
        'условия отбора
        If SheetsService.Range("B23") = 1 Then
            page = 0
        Else
            page = i
        End If
        cSqlEnd = VBA.Trim(VBA.str(SheetsService.Range("A10"))) + _
                    ",'" + Replace_in_Str(pCodeObject, "SVOD_", "") + _
                    "','" + VBA.Trim(pDateBegin) + "'," + _
                    "'" + VBA.Trim(pDateEnd) + "'," + _
                    VBA.Trim(VBA.str(SheetsService.Range("A28").Value)) + ", " + VBA.str(page)
        'выполнение запроса на Server на кол-во записей
        cSql = SheetsService.Range("A40") & " 0," & cSqlEnd
        Set oRecordSet = CreateObject("ADODB.RecordSet")
        oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
        lnRowCount = VBA.Trim(VBA.str(oRecordSet.Fields.Item(0).Value))
        oRecordSet.Close
        Set oRecordSet = Nothing
        If lnRowCount <> 0 Then
            'выполнение запроса на Server
            cSql = SheetsService.Range("A40") & " 1," & cSqlEnd
            Set oRecordSet = CreateObject("ADODB.RecordSet")
            oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
            ' заполнение таблицы с данными
            wrkCount = 0
            While Not oRecordSet.EOF
                If wrkCount <> 0 Then oRecordSet.MoveNext
                SheetsSqlData.Cells(1 + wrkCount * 200, 1).CopyFromRecordset oRecordSet, 200, oRecordSet.Fields.count
                wrkCount = wrkCount + 1
            Wend
            oRecordSet.Close
            Set oRecordSet = Nothing
            Call COPY_DATA(lnRowCount, i)
        End If
    Next
    'вызов GetSQLData_SVOD_After
    If VBA.Trim(SheetsService.Range("B63").Text) <> "" Then
        Application.Run (SheetsService.Range("B63").Text)
    End If
    Exit Sub
doError:
    Call ERROR_EVENT("GetSQLData_SVOD")
End Sub
'---------------------------------------------------------------------------------------------------------------
' Процедура заполнения области отчета нулями
' EdiS\07.10.10\bugs-16042
'---------------------------------------------------------------------------------------------------------------
Sub writeZeros()
Dim i, sheetsReport
    Set sheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)

    For Each i In sheetsReport.Range("MAIN_DATA")
        If (sheetsReport.Cells(i.row, 1) <> 0) And (i.Locked <> True) Then
            i.Value = 0
        End If
    Next
End Sub
'---------------------------------------------------------------------------------------------------------------
