Attribute VB_Name = "INFILE_0503002"
Option Explicit

Public Sub READ_FROM_FILE()
'myError
Dim StrLine As String, codeForm As String
Dim StrMonth As String, StrYear As String, lbExit As Boolean
Dim lnCodeError As Integer, lcFileName As String, SheetsService As Object, sheetsSEEK_POP_SQLDATA As Object
Dim col, row, corrName, CorrINN, LookRange As Range
'myError
Set SheetsService = Sheets("Service")
Set sheetsSEEK_POP_SQLDATA = Sheets("SQLDATA2")

Sheets(Sheets("Service").Range("B19").Text).Range("MAIN_DATA") = ""
Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole)
row = Sheets("Контроль").Range("CLEAR_CONTROL").row
col = Sheets("Контроль").Range("CLEAR_CONTROL").Column

Sheets("Контроль").Range(Sheets("Контроль").Cells(row, col), Sheets("Контроль").Cells(LookRange.row, col + Sheets("Контроль").Range("CLEAR_CONTROL").Columns.count)) = ""
Sheets("Контроль").Range(Sheets("Контроль").Cells(row, col), Sheets("Контроль").Cells(LookRange.row, col + Sheets("Контроль").Range("CLEAR_CONTROL").Columns.count)).Interior.ColorIndex = xlNone

lcFileName = SheetsService.Range("A31")
'pPermitUpd = True ' для заполнения коллекции для сохранения
Sheets("Service").Range("A37").Value = 0
On Error GoTo ERROR_HANDLE
lnCodeError = 2
Open lcFileName For Input As #1
lineNum = 0

' Считываем шапку файла
lbExit = True
While lbExit
    codeForm = ReadLine() ' Код формы
    If codeForm <> "" Then lbExit = False
Wend

' Дата
lbExit = True
While lbExit
    StrLine = ReadLine()
    If StrLine <> "" Then lbExit = False
Wend

' Считаем дату
StrYear = VBA.Trim(VBA.right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
' Функция получения дат для записи
StrMonth = VBA.Mid(StrYear, 4, 2)
StrYear = VBA.Mid(StrYear, 7, 4)

If Not Formate_date(StrYear, StrMonth, lnCodeError) Then GoTo ERROR_HANDLE  ' неправильно заполнены месяц и год

' Приступаем к считыванию информативной части
corrName = ""
CorrINN = ""
lbExit = True
row = 1
'читаем имя корреспондента
StrLine = ""
While VBA.Trim(StrLine) = ""
    StrLine = ReadLine()
Wend

While lbExit
    If VBA.Trim(StrLine) = "#" Then
        lbExit = False ' Конец считывания файла
    Else
        corrName = StrLine
        'читаем код корреспондента
        While VBA.Trim(CorrINN) = ""
            CorrINN = ReadLine()
        Wend
        CorrINN = VBA.Trim(VBA.right(VBA.Trim(CorrINN), VBA.Len(VBA.Trim(CorrINN)) - VBA.InStr(1, VBA.Trim(CorrINN), "=", vbTextCompare)))
        
        'читаем раздел
        StrLine = ""
        While VBA.Trim(StrLine) = ""
            StrLine = ReadLine()
        Wend
        
        'читаем данные
        StrLine = ReadLine()
        While (VBA.InStr(1, VBA.Trim(StrLine), "9999", vbTextCompare) <> 1) And (VBA.Trim(StrLine) <> "#")
            If VBA.Trim(StrLine) <> "" Then
                sheetsSEEK_POP_SQLDATA.Cells(row, 1).Value = CorrINN
                sheetsSEEK_POP_SQLDATA.Cells(row, 2).Value = corrName
                sheetsSEEK_POP_SQLDATA.Cells(row, 3).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 4).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 5).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 6).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 7).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 8).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 9).Value = getNextSubstr(StrLine, "|")
                sheetsSEEK_POP_SQLDATA.Cells(row, 10).Value = VBA.Trim(getNextSubstr(StrLine, "|"))
                row = row + 1
            End If
            StrLine = ReadLine()
        Wend
        sheetsSEEK_POP_SQLDATA.Cells(row, 1).Value = CorrINN
        sheetsSEEK_POP_SQLDATA.Cells(row, 2).Value = corrName
        sheetsSEEK_POP_SQLDATA.Cells(row, 3).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 4).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 5).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 6).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 7).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 8).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 9).Value = getNextSubstr(StrLine, "|")
        sheetsSEEK_POP_SQLDATA.Cells(row, 10).Value = getNextSubstr(StrLine, "|")
        row = row + 1
        corrName = ""
        CorrINN = ""
        StrLine = ""
        While StrLine = ""
            StrLine = ReadLine()
        Wend
    End If
Wend
sheetsSEEK_POP_SQLDATA.Cells(row, 1).Value = ""


Close #1
' Вызов процедуры записи в журнал успешной записи
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
SheetsService.Range("A59") = 1
Exit Sub
ERROR_HANDLE:
If Err.number = 62 Then ' ошибка чтения файла (конец файла)
    lnCodeError = 1
    On Error GoTo 0
End If
Select Case lnCodeError
    Case 1
        Sheets("Контроль").Cells(row, col) = "Неожиданный конец файла, строка " + VBA.str(lineNum)
    Case 2
        Sheets("Контроль").Cells(row, col) = "Ошибка в заголовке файла, строка " + VBA.str(lineNum)
    Case 7
        Sheets("Контроль").Cells(row, col) = "Неизвесный корреспондент, строка " + VBA.str(lineNum)
    Case 8
        Sheets("Контроль").Cells(row, col) = "Неверная дата отчета, строка " + VBA.str(lineNum)
    Case 9
        Sheets("Контроль").Cells(row, col) = "Нельзя определить код строки, строка " + VBA.str(lineNum)
    Case 10
        Sheets("Контроль").Cells(row, col) = "Нет разделителя, строка " + VBA.str(lineNum)
    Case 11
        Sheets("Контроль").Cells(row, col) = "Неверный тип данных, строка " + VBA.str(lineNum)
    Case Else
        Sheets("Контроль").Cells(row, col) = "Неизвесная ошибка, строка " + VBA.str(lineNum)
End Select
Sheets("Контроль").Cells(row + 1, col) = "Файл не принят"
Sheets("Контроль").Cells(row + 1, col).Interior.ColorIndex = 3
Close #1

' Установка флага конца операции
SheetsService.Range("A59") = 0
End Sub

' Запись в ячейку
Sub Record_data(ByVal lcCodeStr As String, ByVal NumCol As Integer, ByVal lnValue As Single)
Dim LookRange As Range, SheetsReport As Object

On Error GoTo doError

Set SheetsReport = Sheets(Sheets("Service").Range("B19").Text)
Set LookRange = SheetsReport.Range("CODE_STR").Find(lcCodeStr, LookIn:=xlFormulas, lookat:=xlWhole)
If Not LookRange Is Nothing Then
    ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
    SheetsReport.Cells(LookRange.row, pnAddress_Col + NumCol - 2) = lnValue
End If

Exit Sub
doError:
    Call ERROR_EVENT("Record_data")
End Sub

' Процедура сохранения отчета на SQL Server при приеме файла
Sub SAVE_REPORT_FROM_FILE()

Dim SqlStr As String, nCnt As Integer, nCountColl As Integer, nCol As Integer, nCount As Integer
Dim metric As Integer, lnDevide As Long
Dim wrkResultSet As DAO.Recordset, lnLinkObject As Integer, lnObject As Integer, link As String
Dim SheetsService As Object, SheetsReport As Object
Dim DeletedLink As String, lnLink As Long, LookRange As Range, CurrRow As Long
Dim lbExistsValue As Boolean, SqlStr1 As String, SqlStrDel As String
Dim row, col, CorrINN As String, sheetsSEEK_POP_SQLDATA As Object
Dim codeArr() As String, linkArr() As Integer, i As Integer, lineCount As Long, codeCol As Integer, _
    bar As Integer, summa(3) As Double, addFlag As Boolean, div, dep, tgt, exp, sqlStr_raf, lnk, linkCorr, sss

On Error GoTo doError

Set SheetsService = Application.ActiveWorkbook.Sheets("Service")
Set SheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
Set sheetsSEEK_POP_SQLDATA = Sheets("SQLDATA2")
' Сохранение документа в зависимости от режима ввода
' 2 - вставка новых записей
' Определим единицу измерения и переведем в копейки
lnDevide = SheetsService.Range("A29").Value

' Определим есть ли соединение с сервером
On Error GoTo gggg
If pnwrkConnect = "" Then
    Set pnwrkConnect = Nothing
End If
gggg:

On Error GoTo doError

If pnwrkConnect Is Nothing Then
    Call Server_Connect
End If

SqlStr = "SELECT LINK FROM S_OBJECTS WHERE CODE='" + VBA.Trim(SheetsService.Range("A15")) + "'"
' выполнени
Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
' получим LINK  объекта
link = VBA.Trim(VBA.str(wrkResultSet("LINK")))

Set wrkResultSet = Nothing

SqlStr = "SELECT LINK FROM REPORTS WHERE OBJECT=" + link + _
             " AND DATE_BEGIN ='" & VBA.Trim(SheetsService.Range("A18")) + "'" + _
             " AND DATE_END ='" & VBA.Trim(SheetsService.Range("A19")) + "'"
' выполнени
Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
' получим LINK  объекта
If wrkResultSet.RecordCount > 0 Then ' отчет есть
    ' Смотрим настройку перезаписи отчета
     If SheetsService.Range("A60") = 1 Then ' перезаписываем отчет
        ' Удаляем его
        ' получим LINK отчета
        'lnLinkObject = VBA.Trim(VBA.str(wrkResultSet("LINK")))

        SqlStr = "DELETE FROM REPORT_SVOD_DATA WHERE LINK_UP in (select link from report_add_fields where link_up in( select link from reports where object =" + link + _
                 " AND DATE_BEGIN ='" & VBA.Trim(SheetsService.Range("A18")) + "'" + _
                 " AND DATE_END ='" & VBA.Trim(SheetsService.Range("A19")) + "'))"
        SqlStr = SqlStr & "DELETE FROM REPORT_VALUES WHERE LINK_UP in (select link from reports where object =" + link + _
                 " AND DATE_BEGIN ='" & VBA.Trim(SheetsService.Range("A18")) + "'" + _
                 " AND DATE_END ='" & VBA.Trim(SheetsService.Range("A19")) + "')"
        SqlStr = SqlStr & " DELETE FROM REPORT_ADD_FIELDS WHERE LINK_UP in (select link from reports where object =" + link + _
                 " AND DATE_BEGIN ='" & VBA.Trim(SheetsService.Range("A18")) + "'" + _
                 " AND DATE_END ='" & VBA.Trim(SheetsService.Range("A19")) + "')"
        SqlStr = SqlStr & " DELETE FROM REPORTS WHERE object =" + link + _
                 " AND DATE_BEGIN ='" & VBA.Trim(SheetsService.Range("A18")) + "'" + _
                 " AND DATE_END ='" & VBA.Trim(SheetsService.Range("A19")) + "'"
        
        pnwrkConnect.Execute (SqlStr)
     Else
        ' Сделать запись в журнале об существовании отчета
        'Sheets("Контроль").Range("CLEAR_CONTROL").Clear

        Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole)
        row = LookRange.row
        Set LookRange = Nothing

        'row = Sheets("Контроль").Range("CLEAR_CONTROL").row
        col = Sheets("Контроль").Range("CLEAR_CONTROL").Column
        Sheets("Контроль").Cells(row + 1, col) = "Данные уже имеются в базе данных"
        Sheets("Контроль").Cells(row + 2, col) = "Данные файла не сохранены"
        Sheets("Контроль").Cells(row + 2, col).Interior.ColorIndex = 3
        
        SheetsService.Range("A59") = 1
        Exit Sub
     End If
End If
  
' Этап 2 вставка новых записей
    
    lineCount = SheetsService.Range("A9") - SheetsService.Range("C5") + 1
    ReDim codeArr(lineCount)
    ReDim linkArr(lineCount)
    
    codeCol = SheetsReport.Range("CODE_STR").Column
    For i = 1 To lineCount
        lnk = SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), 1).Value
        If lnk <> 0 Then
            linkArr(i) = lnk
            codeArr(i) = VBA.Trim(SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), codeCol))
        End If
    Next
    row = 1
    
    div = ""
    dep = ""
    tgt = ""
    exp = ""
    CorrINN = ""
    SqlStr = ""
    sqlStr_raf = ""
    Do While sheetsSEEK_POP_SQLDATA.Cells(row, 1).Text <> ""
    
        If (CorrINN <> sheetsSEEK_POP_SQLDATA.Cells(row, 1)) _
            Or (div <> sheetsSEEK_POP_SQLDATA.Cells(row, 3)) _
            Or (dep <> sheetsSEEK_POP_SQLDATA.Cells(row, 4)) _
            Or (tgt <> sheetsSEEK_POP_SQLDATA.Cells(row, 5)) _
            Or (exp <> sheetsSEEK_POP_SQLDATA.Cells(row, 6)) _
        Then ' создать запись
            If sheetsSEEK_POP_SQLDATA.Cells(row, 3) = "9999" Then
                GoTo eee
            End If
            CorrINN = sheetsSEEK_POP_SQLDATA.Cells(row, 1)
            div = sheetsSEEK_POP_SQLDATA.Cells(row, 3)
            dep = sheetsSEEK_POP_SQLDATA.Cells(row, 4)
            tgt = sheetsSEEK_POP_SQLDATA.Cells(row, 5)
            exp = sheetsSEEK_POP_SQLDATA.Cells(row, 6)

            ' найдем link корреспондента
            Set wrkResultSet = Nothing
            
            sss = "SELECT LINK FROM S_CORR WHERE INN='" + VBA.Trim(CorrINN) + "'"
            ' выполнени
            Set wrkResultSet = pnwrkConnect.OpenRecordset(sss, dbOpenDynaset)
            ' получим LINK  объекта
            If wrkResultSet.RecordCount > 0 Then ' корреспондент есть
                linkCorr = VBA.Trim(VBA.str(wrkResultSet("LINK")))
            Else
                Set wrkResultSet = Nothing
                sss = "SELECT RECORD FROM object_values_records where link_up in(select link from object_values where property in (select link from s_property where code='UNKNOW_CORR'))"
                Set wrkResultSet = pnwrkConnect.OpenRecordset(sss, dbOpenDynaset)
                linkCorr = VBA.Trim(VBA.str(wrkResultSet("RECORD")))
            End If
            ' вставим запись в table Reports
            Set wrkResultSet = Nothing
            
            SqlStr1 = "INSERT REPORTS (OBJECT,CORR_IN,CORR_OUT,DATE_BEGIN,DATE_END,USERS) VALUES (" + _
                        link + "," + _
                        VBA.Trim(linkCorr) + "," + _
                        "NULL" + "," + _
                        "'" + VBA.Trim(SheetsService.Range("A18")) + "'," + _
                        "'" + VBA.Trim(SheetsService.Range("A19")) + "', NULL)"
            ' выполнение insert на SQL server
            Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr1, dbOpenDynaset)
            ' получим LINK вновь вставленного объекта
            lnObject = VBA.Trim(VBA.str(wrkResultSet("LINK")))
            Set wrkResultSet = Nothing
              
            sqlStr_raf = sqlStr_raf + " EXECUTE V_ADD_REPORT_FIELDS " + VBA.str(lnObject) + ", '" + _
                    VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 3)) + "', '" + _
                    VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 4)) + "', '" + _
                    VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 5)) + "', '" + _
                    VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 6)) + "', '', '' ,'', 1,3,0 "
            'pnwrkConnect.Execute (sqlStr_raf)
            
            
            'insert report_svod_data (link_up,razdel,grafa,summa) values ()
        End If
        If VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 7)) = "800000" Then
            sqlStr_raf = sqlStr_raf + " update report_svod_data set summa=" + VBA.Trim(VBA.str(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 10)) * lnDevide)) + " where Razdel=1 and Grafa=3 And link_up in (select link from report_add_fields where link_up=" + VBA.str(lnObject) + ")"
        End If
        For i = 1 To lineCount
            If codeArr(i) = VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 7)) Then
                SqlStr = SqlStr + " insert report_values (link_up,object,bars,grafs,value) values(" + _
                            VBA.Trim(lnObject) + ", 0," + VBA.Trim(VBA.str(linkArr(i))) + ", 1, " + VBA.Trim(VBA.str(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 8)) * lnDevide)) + ")"
                SqlStr = SqlStr + " insert report_values (link_up,object,bars,grafs,value) values(" + _
                            VBA.Trim(lnObject) + ", 0," + VBA.Trim(VBA.str(linkArr(i))) + ", 2, " + VBA.Trim(VBA.str(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 9)) * lnDevide)) + ")"
                SqlStr = SqlStr + " insert report_values (link_up,object,bars,grafs,value) values(" + _
                            VBA.Trim(lnObject) + ", 0," + VBA.Trim(VBA.str(linkArr(i))) + ", 3, " + VBA.Trim(VBA.str(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 10)) * lnDevide)) + ")"
                GoTo eee
            End If
        Next
eee:
        If (Len(SqlStr) > 300000) Or (Len(sqlStr_raf) > 300000) Then
            ' Выполняем пакет команд
            If sqlStr_raf <> "" Then pnwrkConnect.Execute (sqlStr_raf)
            If SqlStr <> "" Then pnwrkConnect.Execute (SqlStr)
            SqlStr = ""
            sqlStr_raf = ""
        End If
      
        row = row + 1
    Loop
    'остатки
    If sqlStr_raf <> "" Then pnwrkConnect.Execute (sqlStr_raf)
    If SqlStr <> "" Then pnwrkConnect.Execute (SqlStr)
'    pnwrkConnect.Execute (sqlStr_raf)
 '   pnwrkConnect.Execute (SqlStr)

    ' Установка флага конца операции
    SheetsService.Range("A59") = 0

Exit Sub
doError:
    Call ERROR_EVENT("SAVE_REPORT_FROM_FILE")
End Sub

Sub SVOD_TO_FILE()

Dim SheetsService As Object
Dim lcFileName As String, lcPath As String, lcShablon As String, _
    lcKodReg As String, lcNumCor  As String, lnRes As Long, lcDay
Dim SqlStr, wrkResultSet, lnDevide

On Error GoTo doError

        Set SheetsService = Sheets("Service")
        lcPath = SheetsService.Range("A54")
        lnDevide = SheetsService.Range("A29").Value

        Call Server_Connect
        SqlStr = "select [CORR_INN]=(select INN from s_corr where link=r.corr_in), " + _
                "[CORR_NAME]=(select SNAME from s_corr where link=r.corr_in), " + _
                "[DIVISION]=(select code from s_kbk where link= raf.division), " + _
                "[DEPARTMENT]=(select code from s_kbk where link= raf.department), " + _
                "[TARGET_ITEM]=(select code from s_kbk where link= raf.target_item), " + _
                "[EXPEND]=(select code from s_kbk where link= raf.expend), " + _
                "[ITEM]=(select code from s_kbk where link= raf.item), " + _
                "[INCOME]=(select code from s_kbk where link= raf.income), " + _
                "[ADD_BK]=(select code from s_kbk where link= raf.add_bk), " + _
                "[BAR]=rv.bars, " + _
                "[GRAF]=rv.grafs, " + _
                "[VALUE]=rv.value/" + VBA.str(lnDevide) + _
                "from reports r, report_add_fields raf, report_values rv " + _
                "where  r.date_begin='" + VBA.Trim(Sheets("Service").Range("A18").Text) + "' and r.date_end='" + VBA.Trim(Sheets("Service").Range("A19").Text) + "' and r.object in(select link from s_objects where code='DOCUMENTS_0503002') and " + _
                "       r.link=rv.link_up and r.link=raf.link_up " + _
                "order by corr_inn, DIVISION, DEPARTMENT, TARGET_ITEM, EXPEND, bar,graf "

        ' выполнение
        Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
        ' получим LINK  объекта
        If wrkResultSet.RecordCount > 0 Then ' данные есть
                ' заполнение таблицы с данными
                Sheets("SQLDATA2").Range("A1").CopyFromRecordset wrkResultSet
                Sheets("SQLDATA2").Cells(wrkResultSet.RecordCount + 1, 1) = ""
        Else
                MsgBox ("Нет данных для пердачи ")
                GoTo errror
        End If
        Set wrkResultSet = Nothing

MetFile:

lcDay = WeekDay(Date) - 1
If lcDay = 0 Then lcDay = 7

If VBA.Len(VBA.Trim(Sheets("Service").Range("C12").Text)) = 1 Then
    lcShablon = "0" + VBA.Trim(Sheets("Service").Range("C12").Text) + VBA.Trim(VBA.str(lcDay)) + "mm"
Else
    lcShablon = VBA.Trim(Sheets("Service").Range("C12").Text) + VBA.Trim(VBA.str(lcDay)) + "mm"
End If
lcNumCor = "00"
lcFileName = lcPath & lcShablon & lcNumCor & ".txt"
' Проверим а есть ли файл
If Dir(lcFileName) <> "" Then
    lnRes = MsgBox("Файл " & lcShablon & lcNumCor & ".txt " & "уже существует, перезаписать его ?", vbQuestion + vbYesNoCancel, pcNameApp & "Внимание")
    Select Case lnRes
        Case vbYes
                Call WRITE_TO_FILE(lcFileName)
        Case vbNo
                lcNumCor = InputBox("Введите номер коррекции", pcNameApp & "Внимание", lcNumCor)
                If lcNumCor = "" Then Exit Sub
                GoTo MetFile:
        Case vbCancel
    End Select
Else
    Call WRITE_TO_FILE(lcFileName)
errror:
End If

Exit Sub
doError:
    Call ERROR_EVENT("SVOD_TO_FILE")
End Sub

Sub WRITE_TO_FILE(ByVal lcFileName As String)
Dim SheetsService As Object, SheetsReport As Object, sheetsSEEK_POP_SQLDATA As Object
Dim lcMonth As String, lcYear As String, lcCodeReg As String, lcCodeDoc As String, lcDate As String, _
    lnOutEmptyBars  As Integer, lcLineValue As String, lcCodeStr As String, _
    nCnt As Long, nCntCol As Long, lcValue As String, lnSumma As Single, CorrINN As String, row As Long, _
    codeArr() As String, linkArr() As Integer, i As Integer, link As Long, lineCount As Long, codeCol As Integer, _
    bar As Integer, summa(3) As Double, addFlag As Boolean, number As String

On Error GoTo doError

Application.StatusBar = "Подождите ... Идет запись в файл"

Set SheetsService = Sheets("Service")
Set SheetsReport = Sheets(Sheets("Service").Range("B19").Text)
Set sheetsSEEK_POP_SQLDATA = Sheets("SQLDATA2")

lcDate = VBA.Trim(SheetsService.Range("A19"))
With SheetsService
    lcCodeDoc = .Range("C10")
    lcYear = .Range("C12")
End With
Open lcFileName For Output As #1
lcDate = DateAdd("d", 1, VBA.Mid(lcDate, 7, 2) + "." + VBA.Mid(lcDate, 5, 2) + "." + VBA.Mid(lcDate, 1, 4))

' Формирование шапки
Print #1, convert_dos_win(lcCodeDoc,1)
Print #1, convert_dos_win("ДТ = " + IIf(Len(VBA.Trim(VBA.str(Day(lcDate)))) = 1, "0" + VBA.Trim(VBA.str(Day(lcDate))), VBA.Trim(VBA.str(Day(lcDate)))) + "." + IIf(Len(VBA.Trim(VBA.str(Month(lcDate)))) = 1, "0" + VBA.Trim(VBA.str(Month(lcDate))), VBA.Trim(VBA.str(Month(lcDate)))) + "." + VBA.Trim(VBA.str(Year(lcDate))) '+ VBA.mid(lcDate,7,2) + "." + VBA.mid(lcDate,5,2) + "." + VBA.mid(lcDate,1,4),1)
Print #1, ""

lineCount = SheetsService.Range("A9") - SheetsService.Range("C5") + 1
ReDim codeArr(lineCount)
ReDim linkArr(lineCount)

codeCol = SheetsReport.Range("CODE_STR").Column
For i = 1 To lineCount
    link = SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), 1).Value
    If link <> 0 Then
        linkArr(i) = link
        codeArr(i) = VBA.Trim(SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), codeCol))
    End If
Next

row = 1
CorrINN = ""

lcCodeStr = ""
bar = 0
'For i = 1 To 3
'    summa(i) = 0
'Next
addFlag = False
Do While sheetsSEEK_POP_SQLDATA.Cells(row, 1).Text <> ""

    If CorrINN <> sheetsSEEK_POP_SQLDATA.Cells(row, 1) Then
        If CorrINN <> "" Then
            Print #1, "9999 | 999 | 999 | 999 | 999999 | " + Space(15 - VBA.Len(VBA.str(Format(summa(1), "###0.00")))) + VBA.str(Format(summa(1), "###0.00")) + " | " + Space(15 - VBA.Len(VBA.str(Format(summa(2), "###0.00")))) + VBA.str(Format(summa(2), "###0.00")) + " | " + Space(15 - VBA.Len(VBA.str(Format(summa(3), "###0.00")))) + VBA.str(Format(summa(3), "###0.00"))
        End If
        For i = 1 To 3
            summa(i) = 0
        Next
        bar = 0
        lcCodeStr = ""
        CorrINN = sheetsSEEK_POP_SQLDATA.Cells(row, 1).Text
        Print #1, ""
        Print #1, convert_dos_win(VBA.Trim(sheetsSEEK_POP_SQLDATA.Cells(row, 2).Text),1)
        Print #1, convert_dos_win("ИНН=" + CorrINN,1)
        Print #1, ""
        Print #1, convert_dos_win("РД=1",1)
        Print #1, ""
    End If
  
    If bar <> sheetsSEEK_POP_SQLDATA.Cells(row, 10).Value Then
        bar = sheetsSEEK_POP_SQLDATA.Cells(row, 10).Value
        If lcCodeStr <> "" Then
            Print #1, lcCodeStr
        End If
        
        lcCodeStr = sheetsSEEK_POP_SQLDATA.Cells(row, 3).Text
        lcCodeStr = lcCodeStr + " | " + sheetsSEEK_POP_SQLDATA.Cells(row, 4).Text
        lcCodeStr = lcCodeStr + " | " + sheetsSEEK_POP_SQLDATA.Cells(row, 5).Text
        lcCodeStr = lcCodeStr + " | " + sheetsSEEK_POP_SQLDATA.Cells(row, 6).Text
        For i = 1 To lineCount
            If linkArr(i) = bar Then
                lcCodeStr = lcCodeStr + " | " + codeArr(i)
                If VBA.Trim(codeArr(i)) = "800000" Then
                    addFlag = True
                Else
                    addFlag = False
                End If
                GoTo eee
            End If
        Next
eee:
    End If
    If Format(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 12).Value), "###0.00") <> 0 Then
        number = IIf(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 12).Value) < 1, "0" + VBA.Trim(VBA.str(Format(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 12).Value), "###0.00"))), VBA.Trim(VBA.str(Format(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 12).Value), "###0.00"))))
        lcCodeStr = lcCodeStr + " | " + Space(15 - VBA.Len(number)) + number
    Else
        lcCodeStr = lcCodeStr + " | " + Space(15 - VBA.Len("0.00")) + "0.00"
    End If
    If addFlag Then
        summa(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 11).Value)) = summa(VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 11).Value)) + VBA.Val(sheetsSEEK_POP_SQLDATA.Cells(row, 12).Value)
    End If
    row = row + 1
Loop

Print #1, lcCodeStr

Print #1, "9999 | 999 | 999 | 999 | 999999 | " + Space(15 - VBA.Len(VBA.str(Format(summa(1), "###0.00")))) + VBA.str(Format(summa(1), "###0.00")) + " | " + Space(15 - VBA.Len(VBA.str(Format(summa(2), "###0.00")))) + VBA.str(Format(summa(2), "###0.00")) + " | " + Space(15 - VBA.Len(VBA.str(Format(summa(3), "###0.00")))) + VBA.str(Format(summa(3), "###0.00"))

' Формирование заключительной части
Print #1, ""
Print #1, "#"
Print #1, convert_dos_win(SheetsReport.Range("WRITE_1"),1)
Print #1, convert_dos_win(SheetsReport.Range("WRITE_2"),1)
Print #1, convert_dos_win(SheetsReport.Range("WRITE_3"),1)
Close #1
Application.StatusBar = False

Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_FILE")
End Sub

Sub control_999()
Dim LookRange As Range, rowControl, colControl, errorFlag As Boolean
Dim corr As String, rowData, sheetsSQLDATA2 As Object, SqlStr, sum(3)
Dim wrkResultSet As DAO.Recordset, flag, i, hWnd

On Error GoTo doError

'hWnd = FindWindow("XLMAIN", 0)
'LockWindowUpdate (hWnd)

    errorFlag = False
    Set sheetsSQLDATA2 = Sheets("SQLDATA2")
    Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole)
    rowControl = LookRange.row
    Set LookRange = Nothing
    colControl = Sheets("Контроль").Range("CLEAR_CONTROL").Column
    Sheets("Контроль").Cells(rowControl, colControl) = "Проверка контрольных сумм"
    Sheets("Контроль").Cells(rowControl, colControl).Interior.ColorIndex = 6
    rowControl = rowControl + 1
    
    rowData = 1
    corr = ""
    sum(1) = 0
    sum(2) = 0
    sum(3) = 0
    
    While VBA.Trim(sheetsSQLDATA2.Cells(rowData, 1)) <> ""
        If VBA.Trim(sheetsSQLDATA2.Cells(rowData, 7)) = "800000" Then
            sum(1) = sum(1) + VBA.Val(sheetsSQLDATA2.Cells(rowData, 8))
            sum(2) = sum(2) + VBA.Val(sheetsSQLDATA2.Cells(rowData, 9))
            sum(3) = sum(3) + VBA.Val(sheetsSQLDATA2.Cells(rowData, 10))
        Else
            If VBA.Trim(sheetsSQLDATA2.Cells(rowData, 7)) = "999999" Then
                flag = False
                For i = 1 To 3
                    If Format(sum(i), "##0.00") <> Format(VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i)), "##0.00") Then
                        Sheets("Контроль").Cells(rowControl + 1, colControl + 1 + i) = VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                        Sheets("Контроль").Cells(rowControl + 2, colControl + 1 + i) = sum(i)
                        Sheets("Контроль").Cells(rowControl + 3, colControl + 1 + i) = sum(i) - VBA.Val(sheetsSQLDATA2.Cells(rowData, 7 + i))
                        flag = True
                    End If
                    
                    sum(i) = 0
                Next
                If flag Then
                    Sheets("Контроль").Cells(rowControl, colControl) = "Корреспондент " + VBA.Trim(sheetsSQLDATA2.Cells(rowData, 1))
                    Sheets("Контроль").Cells(rowControl + 1, colControl) = "Введено "
                    Sheets("Контроль").Cells(rowControl + 2, colControl) = "Расчитано "
                    Sheets("Контроль").Cells(rowControl + 3, colControl) = "Расхождение "
                    rowControl = rowControl + 4
                    errorFlag = True
                End If
            End If
        End If
        rowData = rowData + 1
    Wend
    
    ' Установка флага конца операции
    If errorFlag Then
        Sheets("Service").Range("A59") = 1
    Else
        Sheets("Service").Range("A59") = 0
    End If

'LockWindowUpdate (0)
Exit Sub
doError:
    Call ERROR_EVENT("control_999")
End Sub

Sub control()
Dim SheetsService As Object, SheetsReport As Object
Dim DeletedLink As String, lnLink As Long, LookRange As Range, CurrRow As Long
Dim lbExistsValue As Boolean, SqlStr1 As String, SqlStrDel As String
Dim row, col, CorrINN As String, sheetsSQLDATA2 As Object
Dim codeArr() As String, linkArr() As Integer, i As Integer, lineCount As Long, codeCol As Integer, _
    bar As Integer, summa(3) As Double, addFlag As Boolean, div, dep, tgt, exp, sqlStr_raf, lnk, linkCorr, sss, _
    errorFlag As Boolean, colControl, hWnd


On Error GoTo doError

'hWnd = FindWindow("XLMAIN", 0)
'LockWindowUpdate (hWnd)

    
    Set SheetsService = Application.ActiveWorkbook.Sheets("Service")
    Set SheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
    Set sheetsSQLDATA2 = Sheets("SQLDATA2")
    colControl = Sheets("Контроль").Range("CLEAR_CONTROL").Column
    
    lineCount = SheetsService.Range("A9") - SheetsService.Range("C5") + 1
    ReDim codeArr(lineCount)
    ReDim linkArr(lineCount)
    
    codeCol = SheetsReport.Range("CODE_STR").Column
    For i = 1 To lineCount
        lnk = SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), 1).Value
        If lnk <> 0 Then
            linkArr(i) = i - 1 + SheetsService.Range("C5")
            codeArr(i) = VBA.Trim(SheetsReport.Cells(i - 1 + SheetsService.Range("C5"), codeCol))
        End If
    Next
    
    errorFlag = False
    
    div = sheetsSQLDATA2.Cells(1, 3)
    dep = sheetsSQLDATA2.Cells(1, 4)
    tgt = sheetsSQLDATA2.Cells(1, 5)
    exp = sheetsSQLDATA2.Cells(1, 6)
    CorrINN = sheetsSQLDATA2.Cells(1, 1)
    row = 1
    GoTo rrr
    Do While sheetsSQLDATA2.Cells(row, 1).Text <> ""
    
        If (CorrINN <> sheetsSQLDATA2.Cells(row, 1)) _
            Or (div <> sheetsSQLDATA2.Cells(row, 3)) _
            Or (dep <> sheetsSQLDATA2.Cells(row, 4)) _
            Or (tgt <> sheetsSQLDATA2.Cells(row, 5)) _
            Or (exp <> sheetsSQLDATA2.Cells(row, 6)) _
        Then ' создать запись
            If sheetsSQLDATA2.Cells(row, 7) <> "999999" Then
            
                Set LookRange = Sheets("Контроль").Range("A6:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole)
                Sheets("Контроль").Cells(LookRange.row, colControl) = "Контроль корреспондента " + CorrINN + ", подраздел " + div + ", ведомство " + dep + ", цел. статья " + tgt + ", вид расхода " + exp
                Sheets("Контроль").Range(Sheets("Контроль").Cells(LookRange.row, colControl), Sheets("Контроль").Cells(LookRange.row, colControl + 4)).Interior.ColorIndex = 6
                
                Application.Names.Add name:="CODE_STR_CONTROL", RefersTo:="=Контроль!$B$" + VBA.Trim(VBA.str(LookRange.row + 1)) + ":$B$60000"
                
                Set LookRange = Nothing
                
                If Not CONTROL_REPORT_FROM_FILE Then
                    errorFlag = True
                End If
                
                SheetsReport.Range("MAIN_DATA") = ""
                SheetsReport.Range("MAIN_DATA").Interior.ColorIndex = xlColorIndexAutomatic
                CorrINN = sheetsSQLDATA2.Cells(row, 1)
                div = sheetsSQLDATA2.Cells(row, 3)
                dep = sheetsSQLDATA2.Cells(row, 4)
                tgt = sheetsSQLDATA2.Cells(row, 5)
                exp = sheetsSQLDATA2.Cells(row, 6)
                GoTo rrr
            End If
        Else
rrr:
            For i = 1 To lineCount
                If codeArr(i) = VBA.Trim(sheetsSQLDATA2.Cells(row, 7)) Then
                    SheetsReport.Cells(linkArr(i), 9).Value = VBA.Val(sheetsSQLDATA2.Cells(row, 8))
                    SheetsReport.Cells(linkArr(i), 10).Value = VBA.Val(sheetsSQLDATA2.Cells(row, 9))
                    SheetsReport.Cells(linkArr(i), 11).Value = VBA.Val(sheetsSQLDATA2.Cells(row, 10))
                    GoTo ttt
                End If
            Next
ttt:
        End If
        row = row + 1
    Loop
    
    Set LookRange = Sheets("Контроль").Range("A6:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole)
    Sheets("Контроль").Cells(LookRange.row, colControl) = "Контроль корреспондента " + CorrINN + ", подраздел " + div + ", ведомство " + dep + ", цел. статья " + tgt + ", вид расхода " + exp
    Sheets("Контроль").Range(Sheets("Контроль").Cells(LookRange.row, colControl), Sheets("Контроль").Cells(LookRange.row, colControl + 4)).Interior.ColorIndex = 6
    
    Application.Names.Add name:="CODE_STR_CONTROL", RefersTo:="=Контроль!$B$" + VBA.Trim(VBA.str(LookRange.row + 1)) + ":$B$60000"
    
    Set LookRange = Nothing
   
    If Not CONTROL_REPORT_FROM_FILE Then
        errorFlag = True
    End If
    
    ' Установка флага конца операции
    If errorFlag Then
        Sheets("Service").Range("A59") = 1
    Else
        Sheets("Service").Range("A59") = 0
    End If
   
'LockWindowUpdate (0)
Exit Sub
doError:
    Call ERROR_EVENT("control")
End Sub
