Attribute VB_Name = "INFILE_0521312"
Option Explicit
Private Blank As Integer, lcKodReg As String, lcCorrName As String
Public kritRow, kritCol As Integer, skiped_str As String, fName As String, sum As Double


Public Sub READ_FROM_FILE()
Dim StrLine, nameRegion, razdel As String
Dim StrMonth As String, StrYear As String, StrDay As String, lbExit As Boolean
Dim lnCodeError As Integer, lcFileName As String, sheetsService As Object
Dim lnColumn1, lnRow1, page, row, col, LookRange As Range, i, codeForm, corrName
Dim iFlag As Integer, initDate As Boolean, initCorr As Boolean
'myError
'Stop
'Sheets(Sheets("Service").Range("B19").Text).Range("MAIN_DATA") = ""
Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)

Set sheetsService = Sheets("Service")

lcFileName = sheetsService.Range("A31")
i = VBA.Len(lcFileName)
While (VBA.Mid(lcFileName, i, 1) <> "\") And i > 1
    i = i - 1
Wend
fName = VBA.Mid(lcFileName, i + 1, (VBA.Len(lcFileName) - i) - (VBA.Len(lcFileName) - VBA.InStr(i, lcFileName, ".")) - 1)

inputErrList = ""
inputErrList = inputErrList + vbCrLf + "Протокол приема " + sheetsService.Range("B47") + fName + ".Rep"
inputErrList = inputErrList + vbCrLf + sheetsService.Range("C2") + " Дата " + VBA.str(Date) + "  Время " + VBA.str(Time)
inputErrList = inputErrList + vbCrLf + "Принимаемый файл  " + lcFileName

'pPermitUpd = True ' для заполнения коллекции для сохранения
Sheets("Service").Range("A37").Value = 0

lineNum = 0

On Error GoTo ERROR_HANDLE
Open lcFileName For Input As #1

corrName = ""
'Stop
' Считываем регион и код ОФК

iFlag = 0
lbExit = True
initDate = False
initCorr = False

'Stop
' Приступаем к считыванию информативной части
inputErrList = inputErrList + vbCrLf + "------------------------------------------------------------"
inputErrList = inputErrList + vbCrLf + "1. Проверка структуры и заголовка файла"

While iFlag <> -1 And iFlag <> 1 And lbExit And (Not initDate Or Not initCorr)
    StrLine = ReadLine(iFlag)
    If iFlag = 3 Or iFlag = 5 Then
       initCorr = True
       codeForm = StrLine
'stop
       inputErrList = inputErrList + vbCrLf + "Корреспондент:  " + convert_dos_win(codeForm + " - " + corrName, 0)
       If iFlag = 3 Then
           If Not Check_Corr(0, 0, VBA.Mid(StrLine, VBA.InStr(StrLine, "=") + 1, VBA.Len(StrLine))) Then
                GoTo ERROR_HANDLE
           End If
       Else
           If Not Check_Corr(VBA.Right(codeForm, VBA.Len(codeForm) - VBA.InStr(codeForm, "=")), lnCodeError) Then
                GoTo ERROR_HANDLE
           End If
       End If
    End If

    If iFlag = 4 Then
       initDate = True
       StrYear = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
       If Not Formate_date(VBA.Year(StrYear), VBA.Month(StrYear), lnCodeError) Then GoTo ERROR_HANDLE  ' неправильно заполнены месяц и год

       inputErrList = inputErrList + vbCrLf + "Период c " + VBA.Right(VBA.Trim(sheetsService.Range("A18")), 2) + "." + VBA.Mid(VBA.Trim(sheetsService.Range("A18")), 5, 2) + "." + VBA.Left(VBA.Trim(sheetsService.Range("A18")), 4) + " по " + VBA.Right(VBA.Trim(sheetsService.Range("A19")), 2) + "." + VBA.Mid(VBA.Trim(sheetsService.Range("A19")), 5, 2) + "." + VBA.Left(VBA.Trim(sheetsService.Range("A19")), 4)
    End If
    If iFlag = 0 And (Not initCorr) And codeForm = "" Then corrName = StrLine

Wend

If Not initDate Then
       inputErrList = inputErrList + vbCrLf + "Данные о дате отчета не найдены"
       lnCodeError = 8
       GoTo ERROR_HANDLE
End If

If Not initCorr Then
       inputErrList = inputErrList + vbCrLf + "Данные о корреспонденте не найдены"
       lnCodeError = 7
       GoTo ERROR_HANDLE
End If

' Приступаем к считыванию информативной части
pnAddress_Col = sheetsService.Range("C6")
lbExit = True
While lbExit
    StrLine = ReadLine()
    If StrLine = "#" Then lbExit = False
        If (StrLine <> "") Then
            If (VBA.InStr(1, StrLine, "=") <> 0) And (VBA.InStr(1, StrLine, convert_dos_win("РД", 1)) <> 0) And (VBA.Left(StrLine, 1) <> "*") Then
                lbExit = False
            Else
                skiped_str = skiped_str + StrLine + "  /* ОЖИДАЛСЯ НОМЕР РАЗДЕЛА */" + vbNewLine
            End If
        End If
Wend
lbExit = True

'StrLine = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))


With sheetsService.Range("KRIT_RAZDEL")
     lnColumn1 = .column
     lnRow1 = .row
End With
While lbExit
        If (StrLine <> "") And ((VBA.InStr(1, VBA.Trim(StrLine), "|", vbTextCompare) = 0)) And (VBA.InStr(1, StrLine, "=") <> 0) And (VBA.InStr(1, StrLine, convert_dos_win("РД", 1)) <> 0) And (VBA.Left(StrLine, 1) <> "*") Then
            'возможно, номер раздела
            sum = 0
            razdel = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
            If VBA.Val(razdel) > 0 Then 'число
                page = IIf(razdel <= 8, razdel - 2, 0)
                If page > 0 Then
                  'выбор страницы
                  ' зададим критерий
                  sheetsService.Cells(lnRow1 + 1, lnColumn1) = page

                  Blank = sheetsService.Cells(lnRow1 + 4, lnColumn1).Value
                  Application.ActiveWorkbook.Sheets(sheetsService.Cells(lnRow1 + 3, lnColumn1).Text).Activate
                  If sheetsService.Range("B22") > 1 Then 'несколько строк в коде
                      kritRow = sheetsService.Range("KRIT_CODE").row
                      kritCol = sheetsService.Range("KRIT_CODE").column
                  End If
                  With sheetsService
                       pnAddress_Row = .Range("C5")
                       pnAddress_Col = .Range("C6")
                  End With
                  ' защита листа - снять
                  If page = 4 Then
                       Sheets(Sheets("Service").Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
                       Sheets(Sheets("Service").Range("B19").Text).Range("MAIN_DATA") = ""
                  End If
                  If page = 1 Or page = 3 Or page = 5 Or page = 6 Then
'Stop
                       Sheets(Sheets("Service").Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
                       For i = Sheets(Sheets("Service").Range("B19").Text).Range("LINK_" + Trim(str(page))).row + Sheets(Sheets("Service").Range("B19").Text).Range("LINK_" + Trim(str(page))).Rows.count To Sheets(Sheets("Service").Range("B19").Text).Range("LINK_" + Trim(str(page))).row Step -1
                                If Sheets(Sheets("Service").Range("B19").Text).Cells(i, 1) > 1 Then
                                    Sheets(Sheets("Service").Range("B19").Text).Rows(i).Delete Shift:=xlUp
                                    sheetsService.Range("A9").Value = sheetsService.Range("A9").Value - 1
                                End If
                       Next
                  End If
                End If
'                If page = 0 Then
'                       fileComment = fileComment + StrLine
'                End If
                If razdel <= 2 Then
                       inputErrList = inputErrList + vbCrLf + "Обнаружен неверный раздел " + razdel
                       GoTo ERROR_HANDLE ' ошибка передачи данных
                End If

            Else
                If page > 0 Then
                    If VBA.Trim(StrLine) = "#" Then
                       lbExit = False ' Конец считывания файла
                    Else
                       If Blank = 1 Then
                          If Not Write_To_Sheets(StrLine, lnCodeError) Then
                             GoTo ERROR_HANDLE ' ошибка передачи данных
                          End If
                       Else
                           GoTo ERROR_HANDLE ' ошибка передачи данных
                       End If
                    End If
                End If
            End If
            GoTo NextLine
        End If
        If VBA.Trim(StrLine) = "#" Then
            lbExit = False ' Конец считывания файла
        Else
            If (StrLine = "") Or (Left(StrLine, 1) = "*") Or (page = 0) Then GoTo NextLine
            ' Считывание значений и заполнение страницы отчета
            If Not Write_To_Sheets(StrLine, lnCodeError) Then
                GoTo ERROR_HANDLE ' ошибка передачи данных
            End If
NextLine:
            StrLine = ReadLine()
        End If
Wend
Close #1
Call CLEAR_CONTROL

If skiped_str = "" Then
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла ошибок не обнаружено"
    ' Установка флага конца операции
    sheetsService.Range("A59") = 1
Else
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла обнаружены ошибки:"
    inputErrList = inputErrList + vbCrLf + skiped_str
    skiped_str = ""
    ' Установка флага конца операции
    sheetsService.Range("A59") = 2
End If
inputErrList = inputErrList + vbCrLf + "------------------------------------------------------------"

' Вызов процедуры записи в журнал успешной записи
'Call WRITE_ERROR_MAG(lnCodeError)
Exit Sub
ERROR_HANDLE:

Call CLEAR_CONTROL
If skiped_str <> "" Then
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла обнаружены ошибки:"
    inputErrList = inputErrList + vbCrLf + skiped_str
    inputErrList = inputErrList + vbCrLf + ""
End If
If Err.number = 62 Then ' ошибка чтения файла (конец файла)
    lnCodeError = 1
    On Error GoTo 0
End If
' Вызов процедуры записи в журнал об ошибке
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
'Sheets("Контроль").Range("CLEAR_CONTROL").CLEAR
row = Sheets("Контроль").Range("CLEAR_CONTROL").row
col = Sheets("Контроль").Range("CLEAR_CONTROL").column
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
inputErrList = inputErrList + vbCrLf + "Ошибка в структуре файла: " + Sheets("Контроль").Cells(row, col)
Sheets("Контроль").Cells(row + 1, col) = "Файл не принят"
Sheets("Контроль").Cells(row + 1, col).Interior.ColorIndex = 3
Close #1

'запишем общие данные в файл отчета
'Open sheetsService.Range("B47") + fName + ".Rep" For Output As #2
'Print #2, inputErrList
'Close #2

sheetsService.Range("A59") = 0
End Sub

' Функция прописки данных в таблицу
Public Function Write_To_Sheets(ByVal lcLine As String, ByRef lnCodeError As Variant) As Boolean
Dim lnFirst As Integer, nCnt As Integer
Dim lcOstStr As String, lcCodeStr As String, lcWork, sheetsService, sheetsReport, sss, sss1
Dim saveStr As String, msg As String, oldSH As String, SqlStr As String, wrkResultSet As DAO.Recordset
'myError
lcOstStr = VBA.Trim(lcLine)
saveStr = lcLine

If Blank = 0 Then
    If chr_count(lcLine, "|") < Sheets("Service").Range("A10") Then
        msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
        GoTo Err
    End If
   For nCnt = 1 To 2
       lnFirst = VBA.InStr(1, lcOstStr, "|", vbTextCompare)
       If (lnFirst = 0) And (nCnt <> 2) Then ' нет разделителя
           Write_To_Sheets = False
           lnCodeError = 10
           Exit Function
       End If
       If nCnt = 2 Then
           If lnFirst <> 0 Then lcWork = VBA.Trim(VBA.Left(lcOstStr, lnFirst - 1)) Else lcWork = VBA.Trim(lcOstStr)
       Else
           lcWork = VBA.Trim(VBA.Left(lcOstStr, lnFirst - 1))
       End If
       If nCnt = 1 Then
           If lcWork = "" Then ' невозможно определить код строки
                msg = "  /* НЕ УКАЗАН КОД СТРОКИ */"
                GoTo Err
           Else
               lcCodeStr = lcWork
           End If
       Else
           If (VBA.Val(lcWork) = 0 And lcWork <> "0.00" And lcWork <> "0") And nCnt <> 1 And lcWork <> "" Then  ' не число, или затесались не цифры
               skiped_str = skiped_str + saveStr + "  /* ОБНАРУЖЕНО НЕЧИСЛОВОЕ ЗНАЧЕНИЕ - " + lcWork + " - записано как 0.00 */" + vbNewLine
           Else
               If VBA.Val(lcWork) <> 0 Then ' если не 0, то пишем
                    msg = Record_data(lcCodeStr, nCnt, VBA.Val(lcWork))
                    If msg <> "" Then
                        GoTo Err
                    End If
               End If
           End If
       End If
   
       lcOstStr = VBA.Right(lcOstStr, VBA.Len(lcOstStr) - lnFirst)
   Next
Else
' Вставить строку


    Set sheetsService = Sheets("Service")
    If chr_count(lcLine, "|") < 1 And sheetsService.Range("B20") < 8 Then
        msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
        GoTo Err
    End If
    Set sheetsReport = Sheets(sheetsService.Range("B19").Text)
    sheetsReport.Cells(sheetsService.Range("A9").Value - 1, 3).Select
    Select Case sheetsService.Range("B20").Value
        Case 1, 2, 3
                If chr_count(lcLine, "|") = 0 Then
                    msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
                    GoTo Err
                End If

                sss1 = convert_dos_win(getNextSubstr(lcOstStr, "|"), 0)
'                sss = getNextSubstr(lcOstStr, "|")
                If (sss1 = "") Then
                    skiped_str = skiped_str + saveStr + "  /* НЕ УКАЗАН КОД БК */" + vbNewLine
                End If

                sss = getNextSubstr(lcOstStr, "|")

                If sheetsService.Range("B20").Value = 2 And (sss1 = "00008020100010000510" Or sss1 = "00008020100010000610") Then

                        Sheets("Раздел_2_4").Select
                        Call Record_data(sss1, 2, VBA.Val(sss))
                        Sheets("Раздел_2_2").Select
                Else
                   If (sss1 = "9700" And sheetsService.Range("B20").Value = 1) Or (sss1 = "00000000000000000000" And sheetsService.Range("B20").Value = 2) Or (sss1 = "00060000000000000000" And sheetsService.Range("B20").Value = 3) Then
                        If (VBA.Val(sss) - sum) > 0.009 Then
                                msg = vbNewLine + " ошибка итоговой суммы, код строки " + sss1 + vbNewLine + "   введено    " + str(VBA.Val(sss)) + vbNewLine + "   рассчитано " + str(sum) + vbNewLine + "   расхождение " + str(sum - VBA.Val(sss))
                                GoTo Err
                        End If
                   Else
                        Call Add_Str
                        Call INSERT_LINK_IN_COLLECTION("INS", sheetsReport.Cells(ActiveCell.row, 1), sheetsService.Range("B20").Value)

                        SqlStr = "select [NAME]=dbo.s_kbk_name((SELECT LINK FROM S_KBK WHERE CODE = '" + sss1 + "' AND OBJECT IN (dbo.obj_id('" + IIf(sheetsService.Range("B20").Value = 1, "DICTIONARY_DIVISION", "DICTIONARY_KBK_INC") + "'), dbo.obj_id('DICTIONARY_F_BK'))))"
                        Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)

                        If wrkResultSet.EOF = False And Not IsNull(wrkResultSet("NAME")) Then
                            sheetsReport.Cells(ActiveCell.row, 3) = VBA.Trim(wrkResultSet("NAME"))
                        Else
                            skiped_str = skiped_str + saveStr + "  /* НЕИЗВЕСТНЫЙ КОД */" + vbNewLine
                        End If

                        sheetsReport.Cells(ActiveCell.row, 4) = sss1
                        sheetsReport.Cells(ActiveCell.row, 5) = VBA.Val(sss)

                        sum = sum + VBA.Val(sss)
                        If (VBA.Val(sss) = 0 And sss <> "0.00" And sss <> "0") And sss <> "" Then  ' не число, или затесались не цифры
                                skiped_str = skiped_str + saveStr + "  /* ОБНАРУЖЕНО НЕЧИСЛОВОЕ ЗНАЧЕНИЕ - " + sss + " - записано как 0.00 */" + vbNewLine
                        End If
                   End If
                End If
        Case 5, 6

                sss1 = convert_dos_win(getNextSubstr(lcOstStr, "|"), 0)
'                sss = getNextSubstr(lcOstStr, "|")
                If (sss1 = "") Then
                    skiped_str = skiped_str + saveStr + "  /* НЕ УКАЗАН КОРРЕСПОНДЕНТ */" + vbNewLine
                End If

                sss = getNextSubstr(lcOstStr, "|")
                
                Call Add_Str
                Call INSERT_LINK_IN_COLLECTION("UPD", sheetsReport.Cells(ActiveCell.row, 1), sheetsService.Range("B20").Value)

                sheetsReport.Cells(ActiveCell.row, 4) = sss1
                sheetsReport.Cells(ActiveCell.row, 3) = VBA.Val(sss)

                SqlStr = "SELECT [NAME]=SNAME FROM S_CORR SC WHERE LINK IN (SELECT SCA.LINK_UP FROM S_CORR_APP SCA WHERE left(SCA.VALUE,2) = '" + sss1 + "' AND OBJECT = dbo.obj_id('COLUMN_DICT_OFK_CODE')) AND LINK IN(SELECT CORR FROM getCorrByType('TUFK'))"
                Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)

                If wrkResultSet.EOF = False Then
                    sheetsReport.Cells(ActiveCell.row, 5) = VBA.Trim(wrkResultSet("NAME"))
                Else
                    skiped_str = skiped_str + saveStr + "  /* НЕИЗВЕСТНЫЙ КОРРЕСПОНДЕНТ */" + vbNewLine
                End If
                If (VBA.Val(sss) = 0 And sss <> "0.00" And sss <> "0") And sss <> "" Then  ' не число, или затесались не цифры
                       skiped_str = skiped_str + saveStr + "  /* ОБНАРУЖЕНО НЕЧИСЛОВОЕ ЗНАЧЕНИЕ - " + sss + " - записано как 0.00 */" + vbNewLine
                End If
        
        Case 8, 9
                sheetsReport.Cells(ActiveCell.row, 3) = convert_dos_win(lcOstStr, 0)
       
    End Select
End If
Write_To_Sheets = True
Exit Function
Err:
skiped_str = skiped_str + saveStr + msg + vbNewLine
Write_To_Sheets = True
End Function
' Запись в ячейку
Function Record_data(ByVal lcCodeStr As String, ByVal NumCol As Integer, ByVal lnValue As Double) As String
Dim LookRange As Range, sheetsReport, sheetsService As Object, shablon
Dim count, i, first
Set sheetsService = Sheets("Service")
Set sheetsReport = Sheets(sheetsService.Range("B19").Text)

    If sheetsService.Range("B22") > 1 Then
       shablon = sheetsService.Range("B21").Text
       count = 0
       For i = 1 To VBA.Len(shablon)
           count = count + VBA.Val(VBA.Mid(shablon, i, 1))
       Next
       If count > VBA.Len(lcCodeStr) Then
           lcCodeStr = lcCodeStr + String(count - VBA.Len(lcCodeStr), "0")
       End If
       first = 1
       For i = 0 To sheetsService.Range("B22") - 1
           'Call SET_CELLS(False, lSheetsReport.Cells(ActiveCell.Row, pnAddress_Col - lSheetsService.Range("E4") + i), ADDSTR_FORM.TextBox3)
           sheetsService.Cells(kritRow + 1, kritCol + i).Value = VBA.Mid(lcCodeStr, first, VBA.Val(VBA.Mid(shablon, i + 1, 1)))
           first = first + VBA.Val(VBA.Mid(shablon, i + 1, 1))
       Next
    
       Set LookRange = sheetsReport.Range("LINK").Find(sheetsService.Cells(kritRow, kritCol - 1), LookIn:=xlFormulas, lookat:=xlWhole)
       If Not LookRange Is Nothing Then
           ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
           If Not sheetsReport.Cells(LookRange.row, sheetsService.Range("C6") + NumCol - 2).Locked Then
               sheetsReport.Cells(LookRange.row, sheetsService.Range("C6") + NumCol - 2) = lnValue
           Else
'               stop
           End If
           Record_data = ""
       Else
           Record_data = "/* НЕИЗВЕСТНЫЙ КОД */"
       End If
   Else
       Set LookRange = sheetsReport.Range("CODE_STR").Find(lcCodeStr, LookIn:=xlFormulas, lookat:=xlWhole)
       If Not LookRange Is Nothing Then
           ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
           If Not sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + NumCol - 2).Locked Then
               sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + NumCol - 2) = lnValue
               Record_data = ""
           Else
               Record_data = "" '/* ЯЧЕЙКА ЗАПРЕЩЕНА ДЛЯ ВВОДА */"
'               stop
           End If
       Else
           Record_data = "/* НЕИЗВЕСТНЫЙ КОД */"
       End If
   End If
End Function

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

Dim SqlStr As String, nCnt As Integer, nCountColl As Integer, nCol As Integer, nCount As Integer
Dim lnDevide As Integer
Dim wrkResultSet As DAO.Recordset, lnLinkObject As Long, lnObject As Long
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 lnColumn1, lnRow1, row11, col11, i, j, row, col

Set sheetsService = Application.ActiveWorkbook.Sheets("Service")
Set sheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
' Сохранение документа в зависимости от режима ввода
' 2 - вставка новых записей
' Определим единицу измерения и переведем в копейки
lnDevide = sheetsService.Range("A29").Value
' Определим есть ли соединение с сервером
If pnwrkConnect Is Nothing Then
    Call Server_Connect
End If
SqlStr = "SELECT LINK FROM REPORTS WHERE OBJECT = " & VBA.Trim(VBA.str(sheetsService.Range("A14"))) + _
             " AND CORR_IN =" & VBA.Trim(VBA.str(sheetsService.Range("A16"))) + _
             " 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_VALUES_STR WHERE LINK_UP IN (" + _
                 "SELECT LINK FROM REPORT_VALUES WHERE LINK_UP=" + VBA.Trim(VBA.str(lnLinkObject)) + _
                 " AND VALUE is NULL" + " )"
        pnwrkConnect.Execute (SqlStr)
        
        SqlStr = "DELETE FROM REPORT_VALUES WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject))
        SqlStr = SqlStr & " DELETE FROM REPORT_APP WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject))
        SqlStr = SqlStr & " DELETE FROM REPORTS WHERE LINK = " + VBA.Trim(VBA.str(lnLinkObject))
        pnwrkConnect.Execute (SqlStr)
     Else
        Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
        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
    Exit Sub ' Сделать запись в журнале об существовании отчета
     End If
End If
lnLinkObject = sheetsService.Range("A14")
' вставим запись в table Reports
SqlStr = "INSERT REPORTS (OBJECT,CORR_IN,CORR_OUT,DATE_BEGIN,DATE_END,USERS,DATE_IN) VALUES (" + _
            VBA.Trim(VBA.str(lnLinkObject)) + "," + _
            VBA.Trim(VBA.str(sheetsService.Range("A16"))) + "," + _
            "NULL" + "," + _
            "'" + VBA.Trim(sheetsService.Range("A18")) + "'," + _
            "'" + VBA.Trim(sheetsService.Range("A19")) + "', NULL, getDate())"
' выполнение insert на SQL server
  Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
' получим LINK вновь вставленного объекта
  lnObject = VBA.Trim(VBA.str(wrkResultSet("LINK")))
  Set wrkResultSet = Nothing


With sheetsService.Range("KRIT_RAZDEL")
     lnColumn1 = .column
     lnRow1 = .row
End With

row11 = sheetsService.Range("KRIT_GRAF").row
col11 = sheetsService.Range("KRIT_GRAF").column

For i = 1 To sheetsService.Range("B23")
    ' установим страницу
    ' зададим критерий
    sheetsService.Cells(lnRow1 + 1, lnColumn1) = i
    If sheetsService.Range("B23") = 1 Then
        Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Range("B19").Text)
    Else
        Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
    End If
    Blank = sheetsService.Cells(lnRow1 + 4, lnColumn1)

    sheetsReport.Activate
    
    ReDim str_status(sheetsService.Range("A10"))
    
    For j = 1 To sheetsService.Range("A10").Value
    'критерий для колонок с данными
        sheetsService.Cells(row11 + 1, col11) = j
        sheetsService.Cells(row11 + 1, col11 + 1) = ""
        str_status(j) = sheetsService.Cells(row11 + 4, col11).Value
    Next
    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With
    
    
' Этап 2 вставка новых записей
    SqlStr = ""
    nCountColl = pINSColl(i).count
    If nCountColl > 0 Then 'есть записи для вставки
        For nCnt = 1 To nCountColl
            SqlStr1 = ""
            lnLink = pINSColl(i)(nCnt)
            Set LookRange = sheetsReport.Range("LINK").Find(lnLink, LookIn:=xlFormulas, lookat:=xlWhole)
            If Not LookRange Is Nothing Then
                CurrRow = LookRange.row
                lbExistsValue = False
                'If str_status(nCnt) = 0 Then
                    For nCol = 0 To sheetsService.Range("A10") - 1
                            If str_status(nCol + 1) = 0 Then
                                SqlStr1 = SqlStr1 + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + _
                                VBA.Trim(VBA.str(lnObject)) + "," + IIf(sheetsService.Range("B23") = 1, "0", VBA.str(i)) + "," + _
                                VBA.Trim(VBA.str(lnLink)) + "," + _
                                VBA.Trim(VBA.str(nCol + 1)) + "," + _
                                VBA.Trim(VBA.str(sheetsReport.Cells(CurrRow, IIf(Blank = 0, pnAddress_Col, 3) + nCol).Value * lnDevide)) + ")"
                                ' Проверка на наличия значений
                                If sheetsReport.Cells(CurrRow, IIf(Blank = 0, pnAddress_Col, 3) + nCol).Value <> 0 Then
                                    lbExistsValue = True
                                End If
                            Else
                                SqlStr1 = SqlStr1 + " EXECUTE V_ADD_REPORT_VALUES " + _
                                            VBA.Trim(VBA.str(lnObject)) + "," + _
                                            IIf(sheetsService.Range("B23") = 1, "0", VBA.str(i)) + "," + _
                                            VBA.Trim(VBA.str(lnLink)) + "," + _
                                            VBA.str(nCol + 1) + "," + _
                                            "NULL" + "," + _
                                            "'" + sheetsReport.Cells(CurrRow, IIf(Blank = 0, pnAddress_Col, 3) + nCol).Text + "'"
                               
                                ' Проверка на наличия значений
                                If sheetsReport.Cells(CurrRow, pnAddress_Col + nCol).Text <> "" Then
                                    lbExistsValue = True
                                End If
                                
                          
                            End If
                    Next
                'End If
                'если все значения = 0 то не записываем
                If lbExistsValue Then
                    SqlStr = SqlStr + SqlStr1
                    lbExistsValue = False
                    ' Заносим в коллекцию уже существующих
                    'pNotEmptyColl(i).Add lnLink, VBA.Trim(VBA.str(lnLink))
                End If
                'Сформируем строку insert на SQL Server
                ' Проверим пакет
                If VBA.Len(SqlStr) > 5000 Then
                    ' Выполняем пакет команд
                    pnwrkConnect.Execute (SqlStr)
                    SqlStr = ""
                End If
            End If
        Next
       ' Удаление из коллекции
        For nCnt = 1 To pINSColl(i).count
            pINSColl(i).Remove (1)
        Next
        'Выполним оставшиеся insert на SQL Server
        If SqlStr <> "" Then
            pnwrkConnect.Execute (SqlStr)
        End If
    End If
Next
sheetsService.Cells(lnRow1 + 1, lnColumn1) = ""
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub

'сохранение данных для передачи
Sub SVOD_TO_FILE()
Dim sheetsService As Object
Dim lcFileName As String, lcPath As String, lcShablon As String, _
    lcRepName As String, lcNumCor As String, lnRes As Long, SqlStr, wrkResultSet, lcDay
'Stop
        Set sheetsService = Sheets("Service")
        lcPath = sheetsService.Range("A54")

'        If VBA.Trim(sheetsService.Range("C11")) <> "" Then ' корреспондент есть
                ' заполнение таблицы с данными
                'Sheets("SEEK_POP_SQLDATA").Range("A2").CopyFromRecordset wrkResultSet
                lcKodReg = VBA.Left(VBA.Trim(sheetsService.Range("C11")), 2) 'Sheets("SEEK_POP_SQLDATA").Range("A2").Value
                lcCorrName = VBA.Trim(sheetsService.Range("C13"))
               sheetsService.Range("A16") = Sheets("SEEK_POP_SQLDATA").Cells(2, 1).Value
'        Else
'                MsgBox ("Корреспондент не имеет кода ОФК ")
'                GoTo errror
'        End If
'        Set wrkResultSet = Nothing
'       lcKodReg = "063"
'        If VBA.Len(lcKodReg) = 1 Then
'            lcKodReg = "0" + lcKodReg
'        End If
'        lcShablon = lcKodReg & "600R"
'        lcNumCor = "00"
'        lcDay = WeekDay(Date) - 1
'        If lcDay = 0 Then lcDay = 7
'
'MetFile:
'lcFileName = lcPath & lcShablon & lcNumCor & VBA.Trim(VBA.str(lcDay)) & ".txt"
' Проверим а есть ли файл
'If Dir(lcFileName) <> "" Then
'    lnRes = MsgBox("Файл " & lcFileName & " уже существует, перезаписать его ?", 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
If sheetsService.Range("B50").Text <> "" Then
    lcFileName = sheetsService.Range("B49").Value 'lcPath & lcShablon & lcNumCor & VBA.Trim(VBA.str(lcDay)) & ".txt"
    lcRepName = sheetsService.Range("B50").Value
Else
        'Stop
    lcFileName = lcPath & VBA.Trim(Sheets("Service").Range("C11").Text) & "600" & "r1" & VBA.Trim(VBA.str(lcDay))
    lcRepName = lcFileName + ".rep"
    lcFileName = lcFileName + ".txt"
End If
'    lcFileName = sheetsService.Range("B49")
'    lcRepName = sheetsService.Range("B50")
'    Stop
    Call WRITE_TO_FILE(lcFileName, lcRepName)
errror:
'End If
End Sub

Sub WRITE_TO_FILE(ByVal lcFileName As String, lcRepName As String)
Dim sheetsService As Object, sheetsReport As Object
Dim lcMonth As String, lcYear As String, lcDay As String, lcCodeReg As String, lcCodeDoc As String, _
    lnOutEmptyBars  As Integer, lcLineValue As String, lcCodeStr As String, _
    nCnt As Long, nCntCol As Long, lcValue As String, lnSumma As Double, lnColumn1, lnRow1, row11, col11, i, page, j, oldSheets, hWnd, lcDate As String, str As String
Dim tempStr As String
'Stop
'Sheets("Service").Visible = True
'myError
'On Error GoTo doError
Application.StatusBar = "Подождите ... Идет запись в файл"
hWnd = FindWindow("XLMAIN", 0)
LockWindowUpdate (hWnd)
Application.ScreenUpdating = False

Set sheetsService = Sheets("Service")
Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
Set oldSheets = ActiveSheet
lcDate = VBA.Trim(sheetsService.Range("A19"))

With sheetsService
     lnOutEmptyBars = .Range("C14")
End With

lcDate = DateAdd("d", 1, VBA.Mid(lcDate, 7, 2) + "." + VBA.Mid(lcDate, 5, 2) + "." + VBA.Mid(lcDate, 1, 4))
lcDate = VBA.Format(lcDate, "dd.mm.yy")
Open lcFileName For Output As #1
'Open lcRepName For Output As #2
'    lcYear = Year(Date)
'    lcMonth = Month(Date)
'    lcDay = Day(Date)
' Формирование шапки

Call writeHead
'Print #1, convert_dos_win(lcCorrName, 1)
'Print #1, convert_dos_win("УК=" + lcKodReg, 1)
'Print #1, convert_dos_win("ДТ=" + lcDate, 1) '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)))

' Формирование информативной части
With sheetsService.Range("KRIT_RAZDEL")
     lnColumn1 = .column
     lnRow1 = .row
End With

row11 = sheetsService.Range("KRIT_GRAF").row
col11 = sheetsService.Range("KRIT_GRAF").column

'Stop
For i = 1 To sheetsService.Range("B23")

    page = i + 1
    sheetsService.Cells(lnRow1 + 1, lnColumn1) = i
    If sheetsService.Range("B23") = 1 Then
        Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Range("B19").Text)
    Else
        Set sheetsReport = Application.ActiveWorkbook.Sheets(sheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
    End If
    Blank = sheetsService.Cells(lnRow1 + 4, lnColumn1)

    sheetsReport.Activate
    
    ReDim str_status(sheetsService.Range("A10"))
    
    For j = 1 To sheetsService.Range("A10").Value
    'критерий для колонок с данными
        sheetsService.Cells(row11 + 1, col11) = j
        sheetsService.Cells(row11 + 1, col11 + 1) = ""
        str_status(j) = sheetsService.Cells(row11 + 4, col11).Value
    Next
    
    
    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With

    If VBA.InStr(1, "," + Sheets("Service").Range("B46").Text + ",", "," + VBA.Trim(VBA.str(i)) + ",") <> 0 Then
    Print #1, ""
    Print #1, convert_dos_win("РД=" + VBA.Trim(VBA.str(page + 1)), 1)
    Print #1, ""
    
    For nCnt = pnAddress_Row To 1 + sheetsService.Range("A9")
        
        Select Case page
            Case 5
                If sheetsReport.Cells(nCnt, 2) <> 0 Then
                    lcCodeStr = getCode(nCnt)
                    lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(15 - VBA.Len(VBA.Trim(lcCodeStr)))
                    lnSumma = 0
                    lcValue = ""
                    For nCntCol = pnAddress_Col To pnAddress_Col + sheetsService.Range("A10") - 1
                        lnSumma = lnSumma + sheetsReport.Cells(nCnt, nCntCol).Value
                        tempStr = Replace_in_Str(Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, nCntCol).Value)), "0.00"), ",", ".")
                        lcValue = lcValue + "|" + VBA.Space(15 - VBA.Len(tempStr)) + tempStr
                    Next
                End If
            Case 2, 3, 4
                If (VBA.Trim(sheetsReport.Cells(nCnt, 4).Value) <> "" Or VBA.Trim(sheetsReport.Cells(nCnt, 1).Value) <> "") Then  'And (sheetsReport.Cells(nCnt, 1).Value > 1)
                    lcCodeStr = VBA.Trim(sheetsReport.Cells(nCnt, 4)) '+ VBA.Trim(sheetsReport.Cells(nCnt, 4)) + VBA.Trim(sheetsReport.Cells(nCnt, 5))
                    lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(20 - VBA.Len(VBA.Trim(lcCodeStr)))
                    lnSumma = 0
                    lcValue = ""
                    lnSumma = lnSumma + sheetsReport.Cells(nCnt, 5).Value
                    tempStr = Replace_in_Str(Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, 5).Value)), "0.00"), ",", ".")
                    lcValue = "|" + VBA.Space(15 - VBA.Len(tempStr)) & tempStr
                    
'                    For nCntCol = 4 To 5
'                        If str_status(nCntCol - 2) = 0 Then
'                            lnSumma = lnSumma + sheetsReport.Cells(nCnt, nCntCol).Value
'                            tempStr = Replace_in_Str(Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, nCntCol).Value)), "0.00"), ",", ".")
'                            lcValue = lcValue + "|" + VBA.Space(15 - VBA.Len(tempStr)) & tempStr
'                        Else
'                            lcValue = lcValue + "|" + convert_dos_win(VBA.Trim(sheetsReport.Cells(nCnt, nCntCol).Text), 1)
'                        End If
'                    Next
                End If
            Case 6, 7
                If (VBA.Trim(sheetsReport.Cells(nCnt, 4).Value) <> "" Or (VBA.Trim(sheetsReport.Cells(nCnt, 1).Value) <> "" And sheetsReport.Cells(nCnt, 1).Value > 1)) Then 'And (sheetsReport.Cells(nCnt, 1).Value > 1)

                    lcCodeStr = VBA.Trim(sheetsReport.Cells(nCnt, 4)) '+ VBA.Trim(sheetsReport.Cells(nCnt, 4)) + VBA.Trim(sheetsReport.Cells(nCnt, 5))
                    lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(5 - VBA.Len(VBA.Trim(lcCodeStr)))
                    lnSumma = 0
                    lcValue = ""
                    lnSumma = lnSumma + sheetsReport.Cells(nCnt, 3).Value
                    tempStr = Replace_in_Str(Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, 3).Value)), "0.00"), ",", ".")
                    lcValue = "|" + VBA.Space(15 - VBA.Len(tempStr)) & tempStr
                End If

            Case 80, 81
                lcCodeStr = ""
                If VBA.Trim(sheetsReport.Cells(nCnt, 3).Text) <> "" Then
                    lnSumma = 1
                    lcValue = convert_dos_win(VBA.Trim(sheetsReport.Cells(nCnt, 3).Text), 1)
                End If
        End Select
        If VBA.Trim(lcValue <> "") Then
            If lnOutEmptyBars = 1 Then
                Print #1, lcCodeStr & lcValue
            Else
                If lnSumma <> 0 Then
                    Print #1, lcCodeStr & lcValue
                End If
            End If
            lcValue = ""
        End If
    Next
   End If
nextI:
Next
' Формирование заключительной части
If sheetsService.Range("B65").Text <> "" Then
        sheetsService.Range("B65") = Replace_in_Str(sheetsService.Range("B65").Text, vbLf, "~~")
        sheetsService.Range("B65") = Replace_in_Str(sheetsService.Range("B65").Text, "~~", vbCrLf)
        Print #1, convert_dos_win(sheetsService.Range("B65").Text, 1)
Else
        Print #1, convert_dos_win("РД=80", 1)
        Print #1, ""
        Print #1, "#"
        Print #1, convert_dos_win(sheetsService.Range("A50"), 1)
        Print #1, convert_dos_win(sheetsService.Range("A51"), 1)
End If
'Print #1, Application.Names("WRITE_3").RefersToRange.Text
'InputErrList = InputErrList + vbCrLf +  "Контроль файла для передачи в вышестоящий орган."
'Call CONTROL_REPORT_FROM_FILE(lcFileName)
Close #1
'Close #2
Application.StatusBar = False
oldSheets.Activate
LockWindowUpdate (0)
Application.ScreenUpdating = True


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