Attribute VB_Name = "SQLSERVER"
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
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub CLEAR_KRIT_SQLDATA1()
Dim lnColumn, lnRow, 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
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
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
' -------------------------------------------------------------------------------------------------------
' Очищение полей в SQLData1
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub SEEK_POP_GET_DATA(ByVal WhatLoad As Integer, ByVal MultiSelect As Boolean)
Dim lbMulti As Boolean
Dim lcSQLCommand As String
Dim lnColumn, lnRow, 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 wrkCount As Integer
Dim oRecordSet As Object
Dim cSql As String
Dim LookRange As Range

    On Error GoTo ttt
    If oAdoConnect Is Nothing Then
        Call AdoSrvConnect
    End If
    GoTo lll
ttt:
    init_data
    Call AdoSrvConnect
lll:
    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
' -------------------------------------------------------------------------------------------------------
' Процедура выборки расчетных данных
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
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
    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
    oRecordSet.Close
    Set oRecordSet = Nothing
    ' установим флаг загрузки выборки для расчета
    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
' -------------------------------------------------------------------------------------------------------
' Процедура получения и заполнение данными  существующего отчета
' -------------------------------------------------------------------------------------------------------
Sub GetSQLData()
Dim oRecordSet, SheetsService, sheetsReport As Object
Dim cSql, cSqlEnd As String
Dim lnRowCount, lnColumn1, lnRow1 As Long
Dim i, wrkCount 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
' -------------------------------------------------------------------------------------------------------
'
' -------------------------------------------------------------------------------------------------------
Sub GetSQLData_SVOD()
'myError
Dim oRecordSet, SheetsService, SheetsSqlData, sheetsReport As Object
Dim cSql, cSqlEnd As String
Dim lnRowCount, lnColumn1, lnRow1 As Long
Dim page, i, 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
    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 = oRecordSet.Fields("Rec").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
        ' количество элементов в таблице
        Call COPY_DATA(lnRowCount, i)
    End If
Next
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
' -------------------------------------------------------------------------------------------------------
' Процедура заполнения 0.00 отчета
' 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
' -------------------------------------------------------------------------------------------------------
