Attribute VB_Name = "INFILE_F612"
Option Explicit
Public lcKodReg As String, Razdel As Integer, skiped_str As String, fName

Public Type pageType
            razdelName As String
            grafCount As String
        End Type
Public razdelData() As pageType
Public codeArr() As String, linkArr() As Integer

Public Type codeType
            codeArr() As String
            linkArr() As Integer
        End Type
Public codeData() As codeType, itogStr As Integer
' -------------------------------------------------------------------------------------------------------
' Возвращает код из строки target
' sep -  разделитель составного кода, pageName -  имя листа
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function getCodeExt(ByVal target As Long, Optional sep As String = "", Optional pageName As String = "", Optional wBook As Workbook = Nothing) As String
    Dim lSheetsService, lSheetsReport, temp, i, pnAddress_Col
    Dim oldSheet
    On Error GoTo 0
    If wBook Is Nothing Then Set wBook = Application.ThisWorkbook
    Set lSheetsService = Sheets("Service")
    Set lSheetsReport = wBook.Sheets(IIf(pageName = "", Sheets("Service").Range("B19").Text, pageName))
    temp = ""
    Set oldSheet = Application.ThisWorkbook.ActiveSheet
    If pageName <> "" Then lSheetsReport.Activate
    pnAddress_Col = lSheetsService.Range("C6")
    If lSheetsService.Range("B22").Value = 1 Then
       temp = VBA.Trim(lSheetsReport.Cells(target, pnAddress_Col - lSheetsService.Range(lSheetsService.Range("E1"))))
    Else
       temp = ""
       For i = 0 To VBA.Len(lSheetsService.Range("B21")) - 1
           temp = temp + IIf(sep <> "" And i <> 0, sep, "") + lSheetsReport.Cells(target, pnAddress_Col - lSheetsService.Range(lSheetsService.Range("E1")) + i).Text
       Next
    End If
fff:
    getCodeExt = temp
    If pageName <> "" Then oldSheet.Activate
    Application.ThisWorkbook.Activate
Exit Function
doError:
    Call ERROR_EVENT("getCode")
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура чтения XLS файла при приеме
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub READ_FROM_FILE_XLS(bookName As String)
Dim StrLine, codeForm, StrMonth, StrYear, lcFileName, tempStr As String, str As String
Dim lbExit, div_flag, dep_flag, tgt_flag, exp_flag, code_flag, initDate, initCorr As Boolean
Dim lnCodeError, col, row As Long
Dim Razdel, i, j, k, iFlag, sepCount As Integer
Dim sheetsService, SheetSeek_Pop_SqlData As Object
Dim LookRange As Range
Dim importBook As Workbook
    
    skiped_str = ""
    Set sheetsService = Sheets("Service")
    Set SheetSeek_Pop_SqlData = Sheets("SQLDATA2")
    'прочитаем данные по разделам
    ReDim razdelData(sheetsService.Range("B23"))
    ReDim codeData(sheetsService.Range("B23"))
    'чистим критерий
    With sheetsService
        .Range(.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN), .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + KRIT_GRAF_COLUMNCOUNT - 1)) = ""
        .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
    End With
    Set importBook = Application.Workbooks(bookName)
    sheetsService.Visible = True
    On Error GoTo ttt
    If oAdoConnect Is Nothing Then
ttt:    Call AdoSrvConnect
    End If
    If sheetsService.Range("B23") > 1 Then
    'читаем структуру отчета
    For i = 1 To sheetsService.Range("B23")
        sheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
        sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
        razdelData(i).razdelName = sheetsService.Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).Text
        sheetsService.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 2) = i
        sheetsService.Cells(KRIT_GRAF_ROW + 6, KRIT_GRAF_COLUMN).CALCULATE
        razdelData(i).grafCount = sheetsService.Cells(KRIT_GRAF_ROW + 6, KRIT_GRAF_COLUMN) - 1
    Next
    Else
        razdelData(1).razdelName = sheetsService.Range("B19").Text
        razdelData(1).grafCount = sheetsService.Cells(KRIT_GRAF_ROW + 6, KRIT_GRAF_COLUMN) - 1
    End If
    'имя файла
    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 = ""

    Sheets("Service").Range("A37").Value = 0
    On Error GoTo ERROR_HANDLE
    lineNum = 0
    lbExit = True
    row = 1

    'Stop
    For i = 1 To sheetsService.Range("B23")
        Razdel = i
        Sheets(razdelData(i).razdelName).Select
        pnAddress_Col = Sheets("Service").Range("C6")
        For j = importBook.Sheets(razdelData(i).razdelName).Range("MAIN_DATA_" + VBA.Trim(VBA.str(Razdel))).row To importBook.Sheets(razdelData(i).razdelName).Range("MAIN_DATA_" + VBA.Trim(VBA.str(Razdel))).row + importBook.Sheets(razdelData(i).razdelName).Range("MAIN_DATA_" + VBA.Trim(VBA.str(Razdel))).Rows.count
            'строка с данными
            If importBook.Sheets(razdelData(i).razdelName).Cells(j, 1) <> 0 Then
                codeForm = getCodeExt(j, "", "", importBook)
                If VBA.Trim(codeForm) = VBA.Trim(getFullCode(j, "", "")) Then
                    For k = 1 To razdelData(Razdel).grafCount
                        Sheets(razdelData(i).razdelName).Cells(j, pnAddress_Col + k - 1) = importBook.Sheets(razdelData(i).razdelName).Cells(j, pnAddress_Col + k - 1)
                    Next
                Else
                    skiped_str = skiped_str + "Несоответствие бланков: данные по коду " + codeForm + " не записаны в базу!!!" + vbCrLf
                End If
            End If
        Next
    Next
lExit:
    Call CLEAR_CONTROL
    importBook.saved = True
    Application.DisplayAlerts = False
    If skiped_str = "" Then
        inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла ошибок не обнаружено"
        ' Установка флага конца операции
        sheetsService.Range("A59") = 1
    Else
        inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла обнаружены ошибки:"
        inputErrList = inputErrList + vbCrLf + skiped_str
        ' Установка флага конца операции
        sheetsService.Range("A59") = 2
    End If
    inputErrList = inputErrList + vbCrLf + "------------------------------------------------------------"
    Close #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
    Call CLEAR_CONTROL
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
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура чтения текстового файла при приеме
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub READ_FROM_FILE()
Dim StrMonth, StrYear, lcFileName, nameRegion, StrDay, codeForm, corrName, cs As String
Dim CodeString As String
Dim StrLine As String
Dim lbExit, razdelFlag, initDate, initCorr As Boolean
Dim lnCodeError, i, maxRazdel, iCounter, CodeSize As Integer
Dim iFlag As Integer
Dim sheetsService As Object
Dim col, row As Long
Dim LookRange As Range

    Sheets(Sheets("Service").Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False ' защита листа - снять
    'подготовка
    If Sheets("Service").Range("B23") = 1 Then
        row = Sheets("Service").Range("KRIT_RAZDEL").row
        col = Sheets("Service").Range("KRIT_RAZDEL").column
        i = 1
        Sheets("Service").Cells(row + 1, col) = i
        Sheets("Service").Cells(row + 2, col).CALCULATE
        While Not IsError(Sheets("Service").Cells(row + 2, col))
            i = i + 1
            Sheets("Service").Cells(row + 1, col) = i
            Sheets("Service").Cells(row + 2, col).CALCULATE
        Wend
        maxRazdel = i - 1
        Sheets("Service").Cells(row + 1, col) = ""
    Else
        maxRazdel = Sheets("Service").Range("B23")
    End If

    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

    If Sheets("Service").Range("B72") <> "" Then 'справка к балансу
        If Sheets("Справка").Range("MAIN_DATA_2").Rows.count > 2 Then
            Sheets("Справка").Rows("9:" + VBA.Trim(VBA.str(9 + Sheets("Справка").Range("MAIN_DATA_2").Rows.count - 3))).Delete
    End If
    End If
 
    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(VBA.Date) + "  Время " + VBA.str(VBA.Time)
    inputErrList = inputErrList + vbCrLf + "Принимаемый файл  " + lcFileName

    Sheets("Service").Range("A37").Value = 0
    On Error GoTo ERROR_HANDLE
    lnCodeError = 2
    lineNum = 0
    Open lcFileName For Input As #1
    skiped_str = ""
    
    'читаем заголовок
    corrName = ""
    iFlag = 0
    lbExit = True
    initDate = False
    initCorr = False
    While iFlag <> -1 And iFlag <> 1 And lbExit And (Not initDate Or Not initCorr)
        StrLine = ReadLine(iFlag)
        If iFlag = 3 Or iFlag = 5 Or iFlag = 6 Or iFlag = 7 Or iFlag = 8 Then
            initCorr = True
            codeForm = StrLine
            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
            End If
            If iFlag = 5 Then
                If Not Check_Corr(VBA.Right(codeForm, VBA.Len(codeForm) - VBA.InStr(codeForm, "=")), lnCodeError) Then
                    GoTo ERROR_HANDLE
                End If
            End If
            If iFlag = 6 Then
                If Not Check_Corr(0, 0, "", VBA.Mid(StrLine, VBA.InStr(StrLine, "=") + 1, VBA.Len(StrLine))) Then
                    GoTo ERROR_HANDLE
                End If
            End If
            If iFlag = 7 Then
                If Not Check_Corr(0, 0, "", "", VBA.Mid(StrLine, VBA.InStr(StrLine, "=") + 1, VBA.Len(StrLine))) Then
                    GoTo ERROR_HANDLE
                End If
            End If
            If iFlag = 8 Then
                If Not Check_Corr(0, 0, "", "", "", VBA.Mid(StrLine, VBA.InStr(StrLine, "=") + 1, VBA.Len(StrLine))) 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
    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)
    inputErrList = inputErrList + vbCrLf + "------------------------------------------------------------"
    inputErrList = inputErrList + vbCrLf + "1. Проверка структуры и заголовка файла"
    ' читаем раздел
    lbExit = True
    While lbExit And Not EOF(1)
        StrLine = ReadLine(iFlag)
        If iFlag = 1 Then
            lbExit = False
        Else
            If VBA.InStr(1, StrLine, "#") = 0 Then skiped_str = skiped_str + StrLine + "  /* ОЖИДАЛСЯ НОМЕР РАЗДЕЛА */" + vbNewLine
        End If
    Wend
    pnAddress_Col = sheetsService.Range("C6")
    Sheets(Sheets("Service").Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False ' защита листа - снять
    lbExit = True
    CodeString = sheetsService.Range("B75").Text
While lbExit
        If iFlag < 0 Then
            lbExit = False ' Конец считывания файла
        Else
            If (StrLine = "") Or (VBA.Left(StrLine, 1) = "*") Then GoTo NextLine
            If iFlag = 1 Then
                Razdel = VBA.Trim(VBA.Right(StrLine, VBA.Len(StrLine) - VBA.InStr(1, StrLine, "=")))
                CodeSize = -1
                If (CodeString <> "") Then
                    cs = getNextSubstr(CodeString, "|")
                    CodeSize = VBA.Val(cs)
                End If
                GoTo NextLine 'раздел
            End If
            If Razdel <= maxRazdel Then
                ' Считывание значений и заполнение страницы отчета
                StrLine = convert_dos_win(StrLine, 0)
                If VBA.InStr(1, StrLine, "|") <> 0 Then
                    If VBA.Trim(sheetsService.Range("B74").Text) <> "" Then ' исключаем доп. код
                        If VBA.Trim(sheetsService.Range("B74").Text) <> "" Then
                            If CodeSize > -1 Then
                                iCounter = 0
                                While iCounter < CodeSize
                                    StrLine = getNextSubstr(StrLine, "|") + VBA.Mid(StrLine, InStr(StrLine, "|"))
                                    iCounter = iCounter + 1
                                Wend
                            Else
                                StrLine = getNextSubstr(StrLine, "|") + VBA.Mid(StrLine, InStr(StrLine, "|"))
                            End If
                        End If
                    End If
                    If Not Write_To_Sheets(StrLine, lnCodeError) Then
                        GoTo ERROR_HANDLE ' ошибка передачи данных
                    End If
                End If
            Else
                If Sheets("Service").Range("B72") <> "" And Razdel = 4 Then
                    If (StrLine = "#") Then GoTo EndLine ' завершение считывания
                    If Not Write_To_SPR(StrLine, lnCodeError) Then
                        GoTo ERROR_HANDLE ' ошибка передачи данных
                    End If
                Else
                    fileComment = fileComment + StrLine + vbCrLf
                End If
            End If
NextLine:
            StrLine = ReadLine(iFlag)
        End If
Wend
EndLine:
Close #1
If skiped_str = "" Then
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла ошибок не обнаружено"
    sheetsService.Range("A59") = 1 ' Установка флага конца операции
Else
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла обнаружены ошибки:"
    inputErrList = inputErrList + vbCrLf + skiped_str
    sheetsService.Range("A59") = 2 ' Установка флага конца операции
End If
inputErrList = inputErrList + vbCrLf + "------------------------------------------------------------"
Exit Sub
ERROR_HANDLE:
If ERR.Number = 62 Then ' ошибка чтения файла (конец файла)
    lnCodeError = 1
    On Error GoTo 0
End If
If skiped_str <> "" Then
    inputErrList = inputErrList + vbCrLf + "- в структуре и заголовке файла обнаружены ошибки:"
    inputErrList = inputErrList + vbCrLf + skiped_str
    inputErrList = inputErrList + vbCrLf + ""
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
inputErrList = inputErrList + vbCrLf + "Ошибка в структуре файла: " + Sheets("Контроль").Cells(row, col)
Close #1
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub
' -------------------------------------------------------------------------------------------------------
' Функция прописки данных в таблицу
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
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, saveStr As String, msg As String
    
    lcOstStr = VBA.Trim(lcLine)
    saveStr = lcLine
    If VBA.Right(lcOstStr, 1) <> "|" Then lcOstStr = lcOstStr + "|"
    If chr_count(lcOstStr, "|") < Sheets("Service").Range("A10") + 1 Then
        msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
        GoTo ERR
    End If
    For nCnt = 1 To Sheets("Service").Range("A10") + 1
        lnFirst = VBA.InStr(1, lcOstStr, "|", vbTextCompare)
        If lnFirst = 0 Then ' нет разделителя
            msg = "  /* НЕТ РАЗДЕЛИТЕЛЯ */"
            GoTo ERR
        End If
        lcWork = VBA.Trim(VBA.Left(lcOstStr, lnFirst - 1))
        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
            End If
            If VBA.Val(lcWork) <> 0 Then ' если не 0, то пишем
                If Not Record_data(lcCodeStr, nCnt, VBA.Val(lcWork)) Then
                    msg = "/* НЕИЗВЕСТНЫЙ КОД */"
                    GoTo ERR
                End If
            End If
        End If
        lcOstStr = VBA.Right(lcOstStr, VBA.Len(lcOstStr) - lnFirst)
    Next

Write_To_Sheets = True
Exit Function
ERR:
skiped_str = skiped_str + saveStr + msg + vbNewLine
Write_To_Sheets = True
End Function
' -------------------------------------------------------------------------------------------------------
' Запись в ячейку
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function Record_data(ByVal lcCodeStr As String, ByVal NumCol As Integer, ByVal lnValue As Double) As Boolean
Dim LookRange As Range, sheetsReport As Object
Dim lll As Range
    ' защита листа - снять
    Sheets(Sheets("Service").Range("B19").Text).Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    Set LookRange = sheetsReport.Range("CODE_STR").Find(lcCodeStr, LookIn:=xlFormulas, lookat:=xlWhole)
nnn:
    If Not LookRange Is Nothing Then
        ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
        If (Razdel = sheetsReport.Cells(LookRange.row, 2)) Or (Razdel = -1) Then
            sheetsReport.Cells(LookRange.row, pnAddress_Col + NumCol - 2) = lnValue
            Record_data = True
        Else
            Set lll = LookRange
            Set LookRange = sheetsReport.Range("CODE_STR").FindNext(LookRange)
            If lll.row <> LookRange.row Then
                GoTo nnn
            End If
        End If
    Else
        Record_data = False
    End If
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура сохранения отчета на SQL Server при приеме файла
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub SAVE_REPORT_FROM_FILE()
Dim cSql, DeletedLink, cSql1, cSqlDel As String
Dim nCnt, nCountColl, nCol, nCount, metric, i As Integer
Dim lnDevide, lnLinkObject, lnObject, lnLink, CurrRow, row, col, hWnd As Long
Dim oRecordSet, sheetsService, sheetsReport As Object
Dim LookRange As Range
Dim lbExistsValue As Boolean

    Set sheetsService = Application.ActiveWorkbook.Sheets("Service")
    Set sheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
    ' Сохранение документа в зависимости от режима ввода
    ' 2 - вставка новых записей
    ' Определим единицу измерения и переведем в копейки
    lnDevide = sheetsService.Range("A29").Value
    ' Определим есть ли соединение с сервером
    If oAdoConnect Is Nothing Then
        Call AdoSrvConnect
    End If
    cSql = "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 oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
    'получим LINK  объекта
    If oRecordSet.RecordCount > 0 Then ' отчет есть
        ' Смотрим настройку перезаписи отчета
        If sheetsService.Range("A60") = 1 Then ' перезаписываем отчет
            ' Удаляем его
            ' получим LINK отчета
            lnLinkObject = VBA.Trim(VBA.str(oRecordSet.Fields("LINK")))
            oRecordSet.Close
            Set oRecordSet = Nothing
            cSql = " DELETE REPORT_VALUES_STR WHERE LINK_UP IN(SELECT LINK FROM REPORT_VALUES WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject)) + ") "
            cSql = cSql & " DELETE FROM REPORT_VALUES WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject))
            cSql = cSql & " DELETE FROM REPORT_APP WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject))
            cSql = cSql & " DELETE FROM REPORTS WHERE LINK = " + VBA.Trim(VBA.str(lnLinkObject))
            oAdoConnect.Execute (cSql)
        Else
            Set LookRange = Sheets("Контроль").Range("A5:A60000").Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
            row = LookRange.row
            Set LookRange = Nothing
            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
    cSql = "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 oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open cSql, oAdoConnect, 2, 1, 1
    'получим LINK вновь вставленного объекта
    lnObject = VBA.Trim(VBA.str(oRecordSet.Fields("LINK")))
    oRecordSet.Close
    Set oRecordSet = Nothing
    
    ' Этап 2 вставка новых записей
    cSql = ""
    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
                cSql1 = ""
                For nCol = 0 To sheetsService.Range("A10") - 1
                        cSql1 = cSql1 + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + _
                        VBA.Trim(VBA.str(lnObject)) + "," + _
                        IIf(sheetsService.Range("B23") = 1, "0", VBA.str(VBA.Val(sheetsService.Range("B23")) - 1)) + "," + _
                        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
                    cSql = cSql + cSql1
                    lbExistsValue = False
                End If
                'Сформируем строку insert на SQL Server
                ' Проверим пакет
                If VBA.Len(cSql) > 300000 Then
                    ' Выполняем пакет команд
                    oAdoConnect.Execute (cSql)
                    cSql = ""
                End If
            End If
        Next
       ' Удаление из коллекции
        For nCnt = 1 To pINSColl(1).count
            pINSColl(1).Remove (1)
        Next
        'Выполним оставшиеся insert на SQL Server
        If cSql <> "" Then
            oAdoConnect.Execute (cSql)
        End If
    End If
    
    If Sheets("Service").Range("B72") <> "" Then 'справка к балансу
        cSql = ""
        For row = Sheets("Справка").Range("MAIN_DATA_2").row To Sheets("Справка").Range("MAIN_DATA_2").row + Sheets("Справка").Range("MAIN_DATA_2").Rows.count - 3
            For col = 1 To 13
                If col = 1 Then
                    cSql = cSql + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + VBA.Trim(VBA.str(lnObject)) + ",1," + VBA.Trim(VBA.str(row - Sheets("Справка").Range("MAIN_DATA_2").row + 1)) + "," + VBA.Trim(VBA.str(col)) + ",null)"
                    cSql = cSql + " INSERT REPORT_VALUES_STR (LINK_UP, VALUE) VALUES(SCOPE_IDENTITY(), '" + VBA.Trim(Sheets("Справка").Cells(row, col)) + "')"
                Else
                    cSql = cSql + " INSERT REPORT_VALUES (LINK_UP,OBJECT,BARS,GRAFS,VALUE) VALUES(" + VBA.Trim(VBA.str(lnObject)) + ",1," + VBA.Trim(VBA.str(row - Sheets("Справка").Range("MAIN_DATA_2").row + 1)) + "," + VBA.Trim(VBA.str(col)) + "," + VBA.Trim(VBA.str(Sheets("Справка").Cells(row, col))) + ")"
                End If
            Next
            If VBA.Len(cSql) > 300000 Then
                oAdoConnect.Execute (cSql)
                cSql = ""
            End If
        Next
        If VBA.Len(cSql) > 0 Then
            oAdoConnect.Execute (cSql)
            cSql = ""
        End If

    End If
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура выгрузки сводного отчета в текстовый файл
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub SVOD_TO_FILE()
Dim sheetsService As Object
Dim lcFileName, lcPath, lcShablon, lcNumCor, cSql, lcDay As String
Dim lcRepName As String
Dim lnRes As Long
    
    Set sheetsService = Sheets("Service")
    lcPath = sheetsService.Range("A54")
    'Иницилизация глобальных переменных
    Call init_data
    On Error GoTo nnn
    If oAdoConnect Is Nothing Then
nnn:    'ADO Соединение
        Call AdoSrvConnect
    End If
    On Error GoTo doError
    lcKodReg = VBA.Left(VBA.Trim(sheetsService.Range("C11")), 2)
    If VBA.Len(lcKodReg) = 1 Then
        lcKodReg = "0" + lcKodReg
    End If

MetFile:
    If sheetsService.Range("B50").Text <> "" Then
        lcFileName = sheetsService.Range("B49").Value
        lcRepName = sheetsService.Range("B50").Value
    Else
        'Stop
        lcFileName = lcPath & VBA.Trim(Sheets("Service").Range("C11").Text) & VBA.Trim(Replace_in_Str(Sheets("Service").Range("A15").Text, "DOCUMENTS_F", "")) & "r1" & VBA.Trim(VBA.str(lcDay))
        lcRepName = lcFileName + ".rep"
        lcFileName = lcFileName + ".txt"
    End If
    Call WRITE_TO_FILE(lcFileName, lcRepName)
    Open lcRepName For Output As #2
    Print #2, convert_dos_win(errList, 1)
    Close #2
    Exit Sub
doError:
    Call ERROR_EVENT("SVOD_TO_FILE")

End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура выгрузки отчета в текстовый файл
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub WRITE_TO_FILE(ByVal lcFileName As String, lcRepName As String)
Dim sheetsService, sheetsReport As Object
Dim lcMonth, lcYear, lcDay, lcCodeReg, lcCodeDoc, lcLineValue, lcValue, lcDate, tempStr As String
Dim lcCodeStr As String
Dim lnOutEmptyBars, Razdel As Integer
Dim nCnt, nCntCol As Long
Dim lnSumma As Double
Dim razdelFlag, killLastSep As Boolean

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

    Set sheetsService = Sheets("Service")
    Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    With sheetsService
        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))
    lcDate = VBA.Format(lcDate, "dd.mm.yy")
    Open lcFileName For Output As #1
    ' Формирование шапки
    Call writeHead
    Print #1, ""
    Print #1, convert_dos_win("РД=1", 1)
    razdelFlag = True
    'Формирование информативной части
    Razdel = 1
   
 'Stop
    killLastSep = True
    For nCnt = pnAddress_Row To 1 + sheetsService.Range("A9")
    If sheetsReport.Cells(nCnt, 1) <> 0 Then
        If (sheetsReport.Cells(nCnt, 2) <> Razdel) And razdelFlag Then
            Razdel = sheetsReport.Cells(nCnt, 2)
            Print #1, ""
            Print #1, convert_dos_win("РД=" + VBA.Trim(VBA.str(Razdel)), 1)
        End If
        lcCodeStr = ""
        lcCodeStr = sheetsReport.Cells(nCnt, pnAddress_Col - sheetsService.Range(sheetsService.Range("E1").Text)) 'getCode(nCnt) '
        If VBA.Len(VBA.Trim(lcCodeStr)) > 2 Then
            lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(20 - VBA.Len(VBA.Trim(lcCodeStr)))
        Else
            lcCodeStr = VBA.Space(20 - VBA.Len(VBA.Trim(lcCodeStr))) & VBA.Trim(lcCodeStr)
        End If
        lcCodeStr = convert_dos_win(lcCodeStr, 1) & "|"
        ' добавляем доп. код
        If VBA.Trim(sheetsService.Range("B74").Text) <> "" Then
                If VBA.Trim(sheetsReport.Cells(nCnt, sheetsService.Range("C6") - sheetsService.Range("E6")).Text) <> "" Then
                        If sheetsService.Range("B74").Text = "|" Then
'stop
                                If VBA.Trim(sheetsReport.Cells(nCnt, sheetsService.Range("C6") - sheetsService.Range("E6")).Text) <> "000 0000 0000000 000 000" Or (sheetsReport.Cells(nCnt, 2) <> 2 And sheetsReport.Cells(nCnt, 2) <> 3) Then
                                        lcCodeStr = lcCodeStr + Replace_in_Str(VBA.Trim(sheetsReport.Cells(nCnt, sheetsService.Range("C6") - sheetsService.Range("E6")).Text), " ", "|") + "|"
                                End If
                        Else
                                lcCodeStr = lcCodeStr + VBA.Trim(sheetsReport.Cells(nCnt, sheetsService.Range("C6") - sheetsService.Range("E6")).Text) + "|"

                        End If
                Else
                        lcCodeStr = lcCodeStr + VBA.Trim(sheetsService.Range("B74").Text) + "|"
                End If
        End If
        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(VBA.Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, nCntCol).Value)), "0.00"), ",", ".")
            lcValue = lcValue & VBA.Space(15 - VBA.Len(tempStr)) & IIf(VBA.Val(tempStr) <> 0, tempStr, "   0") & "|"
        Next
        If killLastSep Then
            lcValue = VBA.Left(lcValue, VBA.Len(lcValue) - 1)
        End If
        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, ""
' Раздел 1 закончен, выгружать КонсТабл, для форм: 0503320, 0503321
IF (sheetsService.Range("A15") = "DOCUMENTS_72N320" OR sheetsService.Range("A15") = "DOCUMENTS_72N321") Then
    Set sheetsReport = Application.ActiveWorkbook.Sheets("КонсТабл")
    sheetsReport.Activate
    Print #1, ""
    Print #1, convert_dos_win("РД=2", 1)
    Razdel =2
    killLastSep = True
    For nCnt = sheetsReport.Range("MAIN_DATA_2").row To 1 + sheetsService.Range("A9")
    If sheetsReport.Cells(nCnt, 1) <> 0 Then
        lcCodeStr = ""
        lcCodeStr = sheetsReport.Cells(nCnt, pnAddress_Col - sheetsService.Range(sheetsService.Range("E1").Text))
        lcCodeStr = convert_dos_win(lcCodeStr, 1) & "|"
        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(VBA.Format(VBA.Val(VBA.str(sheetsReport.Cells(nCnt, nCntCol).Value)), "0.00"), ",", ".")
            lcValue = lcValue & VBA.Space(15 - VBA.Len(tempStr)) & IIf(VBA.Val(tempStr) <> 0, tempStr, "   0") & "|"
        Next
        If killLastSep Then
            lcValue = VBA.Left(lcValue, VBA.Len(lcValue) - 1)
        End If
        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, ""
End If
' Формирование комментария
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)
    If VBA.Trim(sheetsService.Range("B72").Text) <> "" Then
        lcValue = convert_dos_win(Application.Run(sheetsService.Range("B72").Text), 1)
    Else
        lcValue = convert_dos_win(sheetsService.Range("B65").Text, 1)
    End If
    lcValue = Replace_in_Str(lcValue, "%CLOSEYEAR", "")
    Print #1, lcValue
End If
Close #1
Call CONTROL_REPORT_FROM_FILE(lcFileName)
Application.StatusBar = False
Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_FILE")
End Sub
' -------------------------------------------------------------------------------------------------------
' ???
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function AFTER_OUTPUT_BALANS() As String
Dim row As Integer, i As Integer
Dim tmpStr As String, cxStr  As String
On Error GoTo doError
    row = Sheets("Справка").Range("MAIN_DATA_2").row + 1
    While Sheets("Справка").Cells(row, 1) <> "" Or Sheets("Справка").Cells(row + 1, 1) = "Итого"
        If Sheets("Справка").Cells(row + 1, 1) = "Итого" Then row = row + 1
        tmpStr = tmpStr + IIf(Sheets("Справка").Cells(row, 1).Text = "Итого", "8|88888888", VBA.Left(Sheets("Справка").Cells(row, 1).Text, 1) + "|" + VBA.Mid(Sheets("Справка").Cells(row, 1).Text, 2))
        For i = 2 To 13
            tmpStr = tmpStr + "|" + num_To_Str(Sheets("Справка").Cells(row, i), 15)
        Next
        tmpStr = tmpStr + vbCrLf
        row = row + 1
    Wend
    AFTER_OUTPUT_BALANS = Replace_in_Str(Sheets("Service").Range("B65").Text, "%CLOSEYEAR", tmpStr)
Exit Function
doError:
    Call ERROR_EVENT("AFTER_OUTPUT_BALANS")
End Function
' -------------------------------------------------------------------------------------------------------
' Функция прописки данных в таблицу
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function Write_To_SPR(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, saveStr As String, msg As String, sepCount As Integer, row  As Integer
    
    lcOstStr = VBA.Trim(lcLine)
    saveStr = lcLine
    sepCount = 12
    row = Sheets("Справка").Range("MAIN_DATA_2").row + Sheets("Справка").Range("MAIN_DATA_2").Rows.count - 2
    If VBA.Right(lcOstStr, 1) <> "|" Then lcOstStr = lcOstStr + "|"
    If chr_count(lcOstStr, "|") < sepCount + 1 Then
        msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
        GoTo ERR
    End If
    For nCnt = 1 To sepCount + 1
        lnFirst = VBA.InStr(1, lcOstStr, "|", vbTextCompare)
        If lnFirst = 0 Then ' нет разделителя
            msg = "  /* НЕТ РАЗДЕЛИТЕЛЯ */"
            GoTo ERR
        End If
        lcWork = VBA.Trim(VBA.Left(lcOstStr, lnFirst - 1))
        If nCnt = 1 Then
            If lcWork = "" Then ' невозможно определить код строки
                msg = "  /* НЕ УКАЗАН КОД СТРОКИ */"
                GoTo ERR
            Else
                lcCodeStr = lcWork
                If lcCodeStr = "999999999" Then
                        Write_To_SPR = True
                        Exit Function
                End If
                Sheets("Справка").Cells(row, nCnt) = lcCodeStr
            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
                Sheets("Справка").Cells(row, nCnt) = VBA.Val(lcWork)
            End If
        End If
        lcOstStr = VBA.Right(lcOstStr, VBA.Len(lcOstStr) - lnFirst)
    Next
    Sheets("Справка").Rows(row + 1).Insert
Write_To_SPR = True
Exit Function
ERR:
skiped_str = skiped_str + saveStr + msg + vbNewLine
Write_To_SPR = True
End Function
' -------------------------------------------------------------------------------------------------------
