Attribute VB_Name = "INFILE_F606"
Option Explicit
Public lcKodReg As String

Public Sub READ_FROM_FILE()
'myError
Dim StrLine As String
Dim StrMonth As String, StrYear As String, lbExit As Boolean
Dim lnCodeError As Integer, lcFileName As String, SheetsService As Object
Dim col, row, LookRange As Range
'myError

Sheets(Sheets("Service").Range("B19").Text).Range("MAIN_DATA") = ""
Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
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

Set SheetsService = Sheets("Service")
lcFileName = SheetsService.Range("A31")
'pPermitUpd = True ' для заполнения коллекции для сохранения
Sheets("Service").Range("A37").Value = 0
On Error GoTo ERROR_HANDLE
lnCodeError = 2
lineNum = 0
Open lcFileName For Input As #1
' Считываем шапку файла
lbExit = True
While lbExit
    StrLine = ReadLine() ' Код формы
    If StrLine <> "" Then lbExit = False
Wend

lbExit = True
While lbExit
    StrLine = ReadLine()
    If StrLine <> "" Then lbExit = False
Wend
' Считаем код региона
StrLine = VBA.Trim(VBA.right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
' Проверим а есть ли корреспондент с таким кодом региона
If Not Check_Corr(StrLine, lnCodeError) Then GoTo ERROR_HANDLE
lbExit = True
While lbExit
    StrLine = ReadLine()
    If StrLine <> "" Then lbExit = False
Wend
lbExit = True
' Считаем год
StrYear = VBA.Trim(VBA.right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
While lbExit
    StrLine = ReadLine()
    If StrLine <> "" Then lbExit = False
Wend
lbExit = True
' Считаем месяц
StrMonth = VBA.Trim(VBA.right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
' Функция получения дат для записи
If Not Formate_date(StrYear, StrMonth, lnCodeError) Then GoTo ERROR_HANDLE  ' неправильно заполнены месяц и год

' Приступаем к считыванию информативной части
pnAddress_Col = SheetsService.Range("C6")
lbExit = True
While lbExit
    StrLine = ReadLine()
    If StrLine <> "" Then lbExit = False
Wend
lbExit = True
While lbExit
        If VBA.Trim(StrLine) = "#" Then
            lbExit = False ' Конец считывания файла
        Else
            If StrLine = "" Then GoTo NextLine
            ' Считывание значений и заполнение страницы отчета
            If Not Write_To_Sheets(StrLine, lnCodeError) Then
                GoTo ERROR_HANDLE ' ошибка передачи данных
            End If
        End If
NextLine:
        StrLine = ReadLine()
Wend
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
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
Sheets("Контроль").Cells(row + 1, col) = "Файл не принят"
Sheets("Контроль").Cells(row + 1, col).Interior.ColorIndex = 3
Close #1

' Вызов процедуры записи в журнал об ошибке
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
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
Dim lcWork
lcOstStr = VBA.Trim(lcLine)

For nCnt = 1 To 4
    lnFirst = VBA.InStr(1, lcOstStr, "|", vbTextCompare)
    If lnFirst = 0 Then ' нет разделителя
        Write_To_Sheets = False
        lnCodeError = 10
        Exit Function
    End If
    lcWork = VBA.Trim(VBA.Left(lcOstStr, lnFirst - 1))
    If nCnt = 1 Then
        If lcWork = "" Then ' невозможно определить код строки
            Write_To_Sheets = False
            lnCodeError = 9
            Exit Function
        Else
            lcCodeStr = lcWork
        End If
    Else
        If (VBA.Val(lcWork) = 0 And lcWork <> "0") Or (VBA.Len(lcWork) <> VBA.Len(VBA.Val(lcWork))) And nCnt <> 1 Then  ' не число, или затесались не цифры
            Write_To_Sheets = False
            lnCodeError = 11
            Exit Function
        Else
            If VBA.Val(lcWork) <> 0 Then ' если не 0, то пишем
                Call Record_data(lcCodeStr, nCnt, VBA.Val(lcWork))
            End If
        End If
    End If
   
    lcOstStr = VBA.right(lcOstStr, VBA.Len(lcOstStr) - lnFirst)
Next
Write_To_Sheets = True
End Function
' Запись в ячейку
Sub Record_data(ByVal lcCodeStr As String, ByVal NumCol As Integer, ByVal lnValue As Single)
Dim LookRange As Range, SheetsReport As Object
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
End Sub

' Процедура сохранения отчета на SQL Server при приеме файла
Sub SAVE_REPORT_FROM_FILE() 'fileName As String,flag As Boolean
'myerror
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
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, hWnd

'if fileName<>"" then
'   Application.ScreenUpdating = True
'   Application.StatusBar = "Подождите ... Идет сохранение данных файла "+ fileName
'   Application.ScreenUpdating = False
'endif

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 WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject))
        SqlStr = SqlStr & " DELETE FROM REPORTS WHERE LINK = " + VBA.Trim(VBA.str(lnLinkObject))
        pnwrkConnect.Execute (SqlStr)
     Else
        ' Сделать запись в журнале об существовании отчета
        'Sheets("Контроль").Range("CLEAR_CONTROL").Clear

        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
     End If
End If
lnLinkObject = SheetsService.Range("A14")
' вставим запись в table Reports
SqlStr = "INSERT REPORTS (OBJECT,CORR_IN,CORR_OUT,DATE_BEGIN,DATE_END,USERS) 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)"
' выполнение insert на SQL server
  Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
' получим LINK вновь вставленного объекта
  lnObject = VBA.Trim(VBA.str(wrkResultSet("LINK")))
  Set wrkResultSet = Nothing
' Этап 2 вставка новых записей
    SqlStr = ""
    nCountColl = pINSColl(1).count
    If nCountColl > 0 Then 'есть записи для вставки
        For nCnt = 1 To nCountColl
            lnLink = pINSColl(1)(nCnt)
            Set LookRange = SheetsReport.Range("LINK").Find(lnLink, LookIn:=xlFormulas, lookat:=xlWhole)
            If Not LookRange Is Nothing Then
                CurrRow = LookRange.row
                lbExistsValue = False
                SqlStr1 = ""
                For nCol = 0 To SheetsService.Range("A10") - 1
                        SqlStr1 = SqlStr1 + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + _
                        VBA.Trim(VBA.str(lnObject)) + ",0," + _
                        VBA.Trim(VBA.str(lnLink)) + "," + _
                        VBA.Trim(VBA.str(nCol + 1)) + "," + _
                        VBA.Trim(VBA.str(SheetsReport.Cells(CurrRow, pnAddress_Col + nCol).Value * lnDevide)) + ")" '
                        ' Проверка на наличия значений
                        If SheetsReport.Cells(CurrRow, pnAddress_Col + nCol).Value > 0 Then
                            lbExistsValue = True
                        End If
                Next
                'если все значения = 0 то не записываем
                If lbExistsValue Then
                    SqlStr = SqlStr + SqlStr1
                    lbExistsValue = False
                End If
                'Сформируем строку insert на SQL Server
                ' Проверим пакет
                If VBA.Len(SqlStr) > 300000 Then
                    ' Выполняем пакет команд
                    pnwrkConnect.Execute (SqlStr)
                    SqlStr = ""
                End If
            End If
        Next
       ' Удаление из коллекции
        For nCnt = 1 To pINSColl(1).count
            pINSColl(1).Remove (1)
        Next
        'Выполним оставшиеся insert на SQL Server
        If SqlStr <> "" Then
            pnwrkConnect.Execute (SqlStr)
        End If
    End If
' Установка флага конца операции
SheetsService.Range("A59") = 0
End Sub

Sub SVOD_TO_FILE()
Dim SheetsService As Object
Dim lcFileName As String, lcPath As String, lcShablon As String, _
     lcNumCor  As String, lnRes As Long
Dim SqlStr, wrkResultSet  As DAO.Recordset, lcDay

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

        If pnwrkConnect Is Nothing Then
            Call Server_Connect
        End If
        If VBA.Trim(SheetsService.Range("C11")) <> "" Then ' корреспондент есть wrkResultSet.EOF
                ' заполнение таблицы с данными
                'Sheets("SEEK_POP_SQLDATA").Range("A2").CopyFromRecordset wrkResultSet
                lcKodReg = VBA.Trim(SheetsService.Range("C11"))
                'Sheets("SEEK_POP_SQLDATA").Range("A2").Value
'               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 & "606R"
        lcNumCor = "0"
        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("Файл " & 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
End Sub

Sub WRITE_TO_FILE(ByVal lcFileName 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 Single, lcDate As String, razdel, tempStr As String
On Error GoTo doError
Application.StatusBar = "Подождите ... Идет запись в файл"

Set SheetsService = Sheets("Service")
Set SheetsReport = Sheets(Sheets("Service").Range("B19").Text)
With SheetsService
'    lcCodeDoc = .Range("C10")
'    lcCodeReg = .Range("C11")
'    lcYear = .Range("C12")
'    lcMonth = .Range("C13")
    lnOutEmptyBars = .Range("C14")
End With
lcDate = VBA.Trim(SheetsService.Range("A19"))
lcDate = DateAdd("d", 1, VBA.Mid(lcDate, 7, 2) + "." + VBA.Mid(lcDate, 5, 2) + "." + VBA.Mid(lcDate, 1, 4))

'lcDay = IIf(Len(VBA.Trim(Day(lcDate))) = 1, "0" + VBA.Trim(Day(lcDate)), VBA.Trim(Day(lcDate)))
'lcMonth = IIf(Len(VBA.Trim(Month(lcDate))) = 1, "0" + VBA.Trim(Month(lcDate)), VBA.Trim(Month(lcDate)))
'lcYear = VBA.right(VBA.Trim(Year(lcDate)), 2)

Open lcFileName For Output As #1
' Формирование шапки

Print #1, VBA.Trim(Sheets("Service").Range("C13"))
Print #1, "УК = " + lcKodReg
Print #1, "ДТ = " + lcDate 'lcDay + "." + lcMonth + "." + lcYear
Print #1, ""
Print #1, "РД = 1"
' Формирование информативной части
razdel = 1
For nCnt = pnAddress_Row To pnAddress_Row + 1 + SheetsService.Range("A9")
    If SheetsReport.Cells(nCnt, 1) <> 0 Then
        If SheetsReport.Cells(nCnt, 2) <> razdel Then
            razdel = SheetsReport.Cells(nCnt, 2)
            Print #1, ""
            Print #1, "РД = " + VBA.Trim(VBA.str(razdel))
        End If
        lcCodeStr = ""
        lcCodeStr = SheetsReport.Cells(nCnt, pnAddress_Col - 2)
        If VBA.Len(VBA.Trim(lcCodeStr)) > 2 Then
            lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(15 - VBA.Len(VBA.Trim(lcCodeStr)))
        Else
            lcCodeStr = VBA.Space(15 - VBA.Len(VBA.Trim(lcCodeStr))) & VBA.Trim(lcCodeStr)
        End If
        lcCodeStr = 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
        If lnOutEmptyBars = 1 Then
            Print #1, lcCodeStr & lcValue
        Else
            If lnSumma <> 0 Then
                Print #1, lcCodeStr & lcValue
            End If
        End If
    End If
Next
' Формирование заключительной части
Print #1, ""
Print #1, "#"
Print #1, SheetsService.Range("A50")
Print #1, SheetsService.Range("A51")
'Print #1, SheetsReport.Range("WRITE_1")
'Print #1, SheetsReport.Range("WRITE_2")
'Print #1, SheetsReport.Range("WRITE_3")
Close #1
Application.StatusBar = False
Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_FILE")
End Sub
