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

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 - необязательный параметр - имя листа
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 'doError


    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
'           If (VBA.Val(lSheetsReport.Cells(target, pnAddress_Col - lSheetsService.Range(lSheetsService.Range("E1")) + i)) = 0) And (i > 0) And sep = "" And temp <> "" Then GoTo fff
           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


Public Sub READ_FROM_FILE_XLS(bookName As String)
Dim StrLine As String, CodeForm As String
Dim StrMonth As String, StrYear As String, lbExit As Boolean
Dim lnCodeError As Integer, lcFileName As String, sheetsService As Object, sheetsSEEK_POP_SQLDATA As Object
Dim col, row, corrName, CorrINN, LookRange As Range, razdel, i, j
Dim div_flag As Boolean, dep_flag As Boolean, tgt_flag As Boolean, exp_flag As Boolean, code_flag As Boolean      'флаги выгрузки кодов
Dim iFlag As Integer
Dim tempStr As String, str As String
Dim sepCount As Integer, initDate As Boolean, initCorr As Boolean
Dim importBook As Workbook
Dim k As Integer

skiped_str = ""
Set sheetsService = Sheets("Service")
Set sheetsSEEK_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)

'Stop
sheetsService.Visible = True
'Exit Sub

On Error GoTo ttt
If pnwrkConnect Is Nothing Then
ttt:          Call Server_Connect
End If

'читаем структуру отчета
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

'Stop

'имя файла
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 = ""

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

lbExit = True
row = 1

'чистим критерий
With sheetsService
'    .Range(.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN), .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + KRIT_GRAF_COLUMNCOUNT - 1)) = ""
End With

'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.Close
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 + "------------------------------------------------------------"


'Stop
Close #1
' Вызов процедуры записи в журнал успешной записи
'Call WRITE_ERROR_MAG(lnCodeError)

Exit Sub
ERROR_HANDLE:
If Err.Number = 62 Then ' ошибка чтения файла (конец файла)
    lnCodeError = 1
    On Error GoTo 0
End If
'Sheets("Контроль").Range("CLEAR_CONTROL").CLEAR
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
'Close #2

' Вызов процедуры записи в журнал об ошибке
'Call WRITE_ERROR_MAG(lnCodeError)
' Установка флага конца операции
sheetsService.Range("A59") = 0
End Sub

Public Sub READ_FROM_FILE()
Dim StrLine, nameRegion, razdel As String
Dim StrMonth As String, StrYear 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 As Integer, j As Integer, CodeForm, corrName, corrNum As Integer
Dim lcRepPath As String, iFlag As Integer
Dim sheetsReport As Worksheet, fintMode As Boolean
Dim errFlag As Boolean, nMonth As Integer, nYear As Integer, nDay As Integer


'myError
'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)
lcRepPath = VBA.Left(lcFileName, i)
'запишем общие данные в файл отчета
Open lcRepPath + fName + ".Rep" For Output As #2
Print #2, "Протокол приема " + fName + ".Rep"
Print #2, " Дата " + VBA.str(Date) + "  Время " + VBA.str(Time) '"Форма №  " +
Print #2, "Принимаемый файл  " + lcFileName

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

'читаем все файлы из подкаталога
'lcFileName = sheetsService.Range("B47").Text + dir(sheetsService.Range("B47").Text)
'Stop

sheetsService.Range("A59") = 0
On Error GoTo ERROR_HANDLE
'While lcFileName <> "" And lcFileName <> sheetsService.Range("B47").Text
    If VBA.InStr(VBA.LCase(lcFileName), ".dbf") = 0 Then 'текстовый формат
        Open lcFileName For Input As #1
        Print #2, "-------------------------------------------------"
        Print #2, "Прием файла " + lcFileName
        
        lineNum = 0
        StrLine = ReadLine() ' Название региона
        sheetsService.Range("A19") = ""
        sheetsService.Range("A16") = ""
        While StrLine <> "#$" And Not EOF(1) ''читаем заголовок
            If VBA.InStr(StrLine, "РДТ") <> 0 Or VBA.InStr(StrLine, convert_dos_win("РДТ", 1)) <> 0 Then 'дата
                StrYear = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
                ' Функция получения дат для записи
                StrMonth = VBA.Mid(StrYear, 4, 2)
                StrYear = VBA.Mid(StrYear, 7, 4)
                If Not Formate_date(StrYear, StrMonth, lnCodeError) Then GoTo ERROR_HANDLE  ' неправильно заполнены месяц и год
'                Print #2, "Период c " + VBA.Trim(sheetsService.Range("A18")) + " по " + VBA.Trim(sheetsService.Range("A18"))
                Print #2, "Период 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 VBA.InStr(StrLine, "ИСТ") <> 0 Or VBA.InStr(StrLine, convert_dos_win("ИСТ", 1)) <> 0 Then 'отправитель
                ' Считаем код региона
                StrLine = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
                ' Проверим а есть ли корреспондент с таким кодом региона
                If Not Check_Corr(VBA.Trim(StrLine), lnCodeError) Then GoTo ERROR_HANDLE
                Print #2, "Корреспондент:  " + StrLine
            End If
            If VBA.InStr(StrLine, "КОДФ") <> 0 Or VBA.InStr(StrLine, convert_dos_win("КОДФ", 1)) <> 0 Then 'код формы
                StrLine = VBA.Trim(VBA.Right(VBA.Trim(StrLine), VBA.Len(VBA.Trim(StrLine)) - VBA.InStr(1, VBA.Trim(StrLine), "=", vbTextCompare)))
                If StrLine = "650" Then
                    Set sheetsReport = Sheets("Отчет")
                Else
                    If StrLine = "651" Then
                        Set sheetsReport = Sheets("Справочная_таблица")
                    Else
                        If StrLine = "652" Then
                            Set sheetsReport = Sheets("Пояснительная_справка")
                        Else
                            lnCodeError = 12
                            GoTo ERROR_HANDLE
                        End If
                    End If
                End If
                Print #2, "Код формы:  " + StrLine
            End If
            
            StrLine = ReadLine()
        Wend
        If sheetsService.Range("A19").Text = "" Or sheetsService.Range("A16").Text = "" Or sheetsReport Is Nothing Then
            lnCodeError = 13
            GoTo ERROR_HANDLE
        Else
            sheetsService.Range("A59") = 1
        End If
        
        sheetsReport.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
        
        ' чтение информативной части
    '    Stop
        
        StrLine = ReadLine(iFlag)
        While iFlag <> -1
            If Not Write_To_Sheets(StrLine, lnCodeError) Then
                GoTo ERROR_HANDLE ' ошибка передачи данных
            End If
            StrLine = ReadLine(iFlag)
        Wend
        
        If skiped_str = "" Then
            Print #2, "- в структуре и заголовке файла ошибок не обнаружено"
        Else
            Print #2, "- в структуре и заголовке файла обнаружены ошибки:"
            Print #2, skiped_str
        End If
        Print #2, "------------------------------------------------------------"
        
    GoTo nnext
ERROR_HANDLE:
        
        Call CLEAR_CONTROL
        If skiped_str <> "" Then
            Print #2, "- в структуре и заголовке файла обнаружены ошибки:"
            Print #2, skiped_str
            Print #2, ""
        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 12
                Sheets("Контроль").Cells(row, col) = "Неверный код отчета, строка " + VBA.str(lineNum)
            Case 13
                Sheets("Контроль").Cells(row, col) = "Не указан необходимый реквизит в заголовке файла"
            Case Else
                Sheets("Контроль").Cells(row, col) = "Неизвесная ошибка, строка " + VBA.str(lineNum)
        End Select
        Print #2, "Ошибка в структуре файла: " + Sheets("Контроль").Cells(row, col)
        Sheets("Контроль").Cells(row + 1, col) = "Файл не принят"
        Sheets("Контроль").Cells(row + 1, col).Interior.ColorIndex = 3
        
nnext:
        Close #1
    Else
        kritRow = sheetsService.Range("KRIT_CODE").row
        kritCol = sheetsService.Range("KRIT_CODE").column
        
        errFlag = False

        ' определим тип файла (по имени)
        If VBA.UCase(VBA.Left(VBA.Right(lcFileName, 12), 2)) = "65" Then fintMode = False Else fintMode = True
        If Not fintMode Then
                i = LoadData(lcFileName)
'stop
                If i <> 0 Then
                    If VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 1).Text) <> "" Then
                        Select Case VBA.UCase(VBA.Left(VBA.Right(lcFileName, 12), 7)) 'VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 4).Text)
                            Case "65001M_"
                                Set sheetsReport = Sheets("Отчет")
                            Case "65101M_"
                                Set sheetsReport = Sheets("Справочная_таблица")
                            Case Else
                                Print #2, "Неизвестный код формы - " + VBA.Trim(lcFileName)
                                errFlag = True
                                GoTo dbfError
                        End Select
                    End If
                    If Not Check_Corr(VBA.Right("0" + VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 2).Text), 2), lnCodeError) Then
                        Print #2, "Неизвестный корреспондент - " + VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 2).Text)
                        errFlag = True
                        GoTo dbfError
                    End If
'            Stop
'            j = VBA.Val(VBA.Left(VBA.Right("0" + fName, 6), 2))
''''''''' из файла:
            'nMonth = VBA.Val(VBA.Left(VBA.Right("0" + fName, 6), 2)) + 1
            'nYear = VBA.Val(VBA.Left(VBA.Right(fName, 4), 2))
'Stop
                    nMonth = VBA.Val(VBA.Left(VBA.Right("0" + Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 2), 2)) '+ 1
                    nYear = VBA.Val(VBA.Left(Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 4))
'            nDay = VBA.Val(VBA.Mid(Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 5, 2))
            
                    If nMonth = 13 Then
                        nMonth = 1
                        nYear = nYear + 1
                    End If
                    StrMonth = VBA.Right("0" + VBA.Trim(VBA.str(nMonth)), 2)
                    StrYear = VBA.Right("0" + VBA.Trim(VBA.str(nYear)), 2)
                    If Not Formate_date(StrYear, StrMonth, lnCodeError) Then
                        Print #2, "Неверная дата отчета, файл " + lcFileName
                        GoTo dbfError  ' неправильно заполнены месяц и год
                    End If
                    Print #2, "Период 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)
                    Print #2, "Корреспондент:  " + sheetsService.Range("B2")
                    corrNum = Sheets("DBF_EXCHANGE").Cells(2, 2)
                    sheetsReport.Activate
            
                    For j = 2 To i + 1
                        Call Write_To_Sheets_Dbf(j, lnCodeError)
                    Next
                Else
                    Sheets("DBF_EXCHANGE").Visible = True
                    Print #2, "Ошибка при открытии файла: " + lcFileName
                End If
        Else
                i = LoadData(lcFileName, "DBF_EXCHANGE_F")
'Stop
                If i <> 0 Then
                        Select Case VBA.UCase(VBA.Right(lcFileName, 6)) 'VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 4).Text)
                            Case "50.DBF"
                                Set sheetsReport = Sheets("Отчет")
                            Case "51.DBF"
                                Set sheetsReport = Sheets("Справочная_таблица")
                            Case Else
                                Print #2, "Неизвестный код формы - " + VBA.Trim(lcFileName)
                                errFlag = True
                                GoTo dbfError
                        End Select
                    If Not Check_Corr(VBA.Right("0" + VBA.Trim(Sheets("DBF_EXCHANGE_F").Cells(2, 2).Text), 2), lnCodeError) Then
                        Print #2, "Неизвестный корреспондент - " + VBA.Trim(Sheets("DBF_EXCHANGE").Cells(2, 2).Text)
                        errFlag = True
                        GoTo dbfError
                    End If
'            Stop
'            j = VBA.Val(VBA.Left(VBA.Right("0" + fName, 6), 2))
''''''''' из файла:
            nMonth = VBA.Val(VBA.Left(VBA.Right("0" + fName, 6), 2)) + 1
            nYear = VBA.Val(VBA.Left(VBA.Right(fName, 4), 2))
'Stop
'                   nMonth = VBA.Val(VBA.Left(VBA.Right("0" + Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 2), 2))
'                   nYear = VBA.Val(VBA.Left(Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 4))
'            nDay = VBA.Val(VBA.Mid(Sheets("DBF_EXCHANGE").Cells(2, 3).Text, 5, 2))
            
                    If nMonth = 13 Then
                        nMonth = 1
                        nYear = nYear + 1
                    End If
                    StrMonth = VBA.Right("0" + VBA.Trim(VBA.str(nMonth)), 2)
                    StrYear = VBA.Right("0" + VBA.Trim(VBA.str(nYear)), 2)
                    If Not Formate_date(StrYear, StrMonth, lnCodeError) Then
                        Print #2, "Неверная дата отчета, файл " + lcFileName
                        GoTo dbfError  ' неправильно заполнены месяц и год
                    End If
                    Print #2, "Период 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)
                    Print #2, "Корреспондент:  " + sheetsService.Range("B2")
                    corrNum = Sheets("DBF_EXCHANGE_F").Cells(2, 2)
                    sheetsReport.Activate
            
                    For j = 2 To i + 1
                        Call Write_To_Sheets_Dbf_F(j, lnCodeError)
                    Next
                Else
                    Sheets("DBF_EXCHANGE_F").Visible = True
                    Print #2, "Ошибка при открытии файла: " + lcFileName
                End If

        End If
        
        If skiped_str = "" Then
            Print #2, "- в структуре и заголовке файла ошибок не обнаружено"
        Else
            Print #2, "- в структуре и заголовке файла обнаружены ошибки:"
            Print #2, skiped_str
        End If
        
        ' Установка флага конца операции
        sheetsService.Range("A59") = 1
        
dbfError:
        If errFlag = True Then
            Print #2, "Файл " + lcFileName + " не принят"
            sheetsService.Range("A59") = 0
        End If
        
    
    End If
    
'    lcFileName = sheetsService.Range("B47").Text + dir()
'Wend


Close #1
Call CLEAR_CONTROL


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

' Функция прописки данных в таблицу (DBF)
Public Function Write_To_Sheets_Dbf(lcLine As Integer, ByRef lnCodeError As Variant) As Boolean
Dim lnFirst As Integer, nCnt As Integer
Dim lcOstStr As String, lcCodeStr As String, lcWork, sheetsService, sheetsReport, sss
Dim saveStr As String, msg As String
Dim LookRange

' ищем link строки
    
    Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    Sheets("Service").Cells(kritRow + 1, kritCol) = Sheets("DBF_EXCHANGE").Cells(lcLine, 6) 'KL
    Sheets("Service").Cells(kritRow + 1, kritCol + 1) = Sheets("DBF_EXCHANGE").Cells(lcLine, 7) 'KST
'    Sheets("Service").Visible = True
    If Sheets("Service").Cells(kritRow + 1, kritCol - 1) = 0 Then
       Set LookRange = sheetsReport.Range("LINK").Find(Sheets("Service").Cells(kritRow, kritCol - 1), LookIn:=xlFormulas, lookat:=xlWhole)
       If Not LookRange Is Nothing Then
           ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
            For nCnt = 1 To Sheets("Service").Range("A10")
                If Not sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + nCnt - 1).Locked Then
                    sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + nCnt - 1) = Sheets("DBF_EXCHANGE").Cells(lcLine, 7 + nCnt)
                End If
            Next
            Write_To_Sheets_Dbf = True
       Else
            skiped_str = skiped_str + "Не найден LINK строки " + VBA.str(lcLine) + vbNewLine
            Write_To_Sheets_Dbf = False
       End If
    Else
        skiped_str = skiped_str + "Код строки KL = " + VBA.str(Sheets("DBF_EXCHANGE").Cells(lcLine, 3)) + ", KST = " + VBA.str(Sheets("DBF_EXCHANGE").Cells(lcLine, 4)) + " отсутствует в бланке" + vbNewLine
        Write_To_Sheets_Dbf = False
    End If
    
    Write_To_Sheets_Dbf = True
Exit Function
Err:
skiped_str = skiped_str + saveStr + msg + vbNewLine
Write_To_Sheets_Dbf = False
End Function

Public Function Write_To_Sheets_Dbf_F(lcLine As Integer, ByRef lnCodeError As Variant) As Boolean
Dim lnFirst As Integer, nCnt As Integer
Dim lcOstStr As String, lcCodeStr As String, lcWork, sheetsService, sheetsReport, sss
Dim saveStr As String, msg As String
Dim LookRange

' ищем link строки
    
    Set sheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    Sheets("Service").Cells(kritRow + 1, kritCol) = Sheets("DBF_EXCHANGE_F").Cells(lcLine, 3) 'KL
    Sheets("Service").Cells(kritRow + 1, kritCol + 1) = Sheets("DBF_EXCHANGE_F").Cells(lcLine, 4) 'KST
'    Sheets("Service").Visible = True
    If Sheets("Service").Cells(kritRow + 1, kritCol - 1) = 0 Then
       Set LookRange = sheetsReport.Range("LINK").Find(Sheets("Service").Cells(kritRow, kritCol - 1), LookIn:=xlFormulas, lookat:=xlWhole)
       If Not LookRange Is Nothing Then
           ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
            For nCnt = 1 To Sheets("Service").Range("A10")
                If Not sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + nCnt - 1).Locked Then
                    sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + nCnt - 1) = Sheets("DBF_EXCHANGE_F").Cells(lcLine, 5 + nCnt)
                End If
            Next
            Write_To_Sheets_Dbf_F = True
       Else
            skiped_str = skiped_str + "Не найден LINK строки " + VBA.str(lcLine) + vbNewLine
            Write_To_Sheets_Dbf_F = False
       End If
    Else
        skiped_str = skiped_str + "Код строки KL = " + VBA.str(Sheets("DBF_EXCHANGE").Cells(lcLine, 3)) + ", KST = " + VBA.str(Sheets("DBF_EXCHANGE_F").Cells(lcLine, 4)) + " отсутствует в бланке" + vbNewLine
        Write_To_Sheets_Dbf_F = False
    End If
    
    Write_To_Sheets_Dbf_F = True
Exit Function
Err:
skiped_str = skiped_str + saveStr + msg + vbNewLine
Write_To_Sheets_Dbf_F = False
End Function


' Функция прописки данных в таблицу
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
Dim saveStr As String, msg As String
'myError
lcOstStr = VBA.Trim(lcLine)
saveStr = lcLine
If chr_count(lcLine, "|") < Sheets("Service").Range("A10") + Sheets("Service").Range("B22") - 1 Then
    msg = "  /* НЕВЕРНОЕ ЧИСЛО РАЗДЕЛИТЕЛЕЙ */"
    GoTo Err
End If
lcCodeStr = ""
For nCnt = 1 To Sheets("Service").Range("B22")
    lcCodeStr = lcCodeStr + IIf(nCnt > 1, "|", "") + getNextSubstr(lcLine, "|")
Next
For nCnt = 1 To Sheets("Service").Range("A10")
    lcWork = getNextSubstr(lcLine, "|")
    
    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, то пишем
             If Not Record_data(lcCodeStr, nCnt, VBA.Val(lcWork)) Then
                 msg = "/* НЕИЗВЕСТНЫЙ КОД */"
                 GoTo Err
             End If
        End If
    End If

Next
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 Boolean
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) = getNextSubstr(lcCodeStr, "|") '- -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 - 1).Locked Then
               sheetsReport.Cells(LookRange.row, sheetsService.Range("C6") + NumCol - 1) = lnValue
           Else
'               stop
           End If
           Record_data = True
       Else
           Record_data = False
       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 - 1).Locked Then
               sheetsReport.Cells(LookRange.row, Sheets("Service").Range("C6") + NumCol - 1) = lnValue
               Record_data = True
           Else
               Record_data = False
'               stop
           End If
       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)
lnObject = 0
' получим 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" + " AND OBJECT = " + sheetsService.Range("B20").Text + ")"
        pnwrkConnect.Execute (SqlStr)
        
        SqlStr = "DELETE FROM REPORT_VALUES WHERE LINK_UP = " + VBA.Trim(VBA.str(lnLinkObject)) + " AND OBJECT = " + sheetsService.Range("B20").Text
'        SqlStr = SqlStr & " DELETE FROM REPORTS WHERE LINK = " + VBA.Trim(VBA.str(lnLinkObject))
        pnwrkConnect.Execute (SqlStr)
        lnObject = lnLinkObject

     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
Else
        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
End If



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, hWnd
Dim lcFileName As String, lcPath As String, lcShablon As String, _
    lcRepName As String, lcNumCor As String, lnRes As Long, SqlStr, wrkResultSet, lcDay, lcDate_end As String, i As Integer
    
On Error GoTo doError
    hWnd = FindWindow("XLMAIN", 0)
    LockWindowUpdate (hWnd)
    Application.ScreenUpdating = False
    Set sheetsService = Sheets("Service")
    lcPath = sheetsService.Range("A49")
    For i = VBA.Len(sheetsService.Range("B49")) To 1 Step -1
        If VBA.Mid(sheetsService.Range("B49"), i, 1) = "\" Then
             lcPath = VBA.Left(sheetsService.Range("B49"), i)
             Exit For
        End If
    Next
    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
    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
    End If
    
    Open lcRepName For Output As #2
    
    Print #2, "Контроль файла для передачи в вышестоящий орган."
    Call CONTROL_REPORT_FROM_FILE(lcFileName)
    
    If DIR(lcFileName) <> "" Then kill (lcFileName)
    
    SqlStr = "A_EXEC ' DECLARE @r varchar(10) EXECUTE A_GET_PROP ''DOCUMENTS_0524312'', ''NASTR_SOURCE_TYPE'', 0, @r OUTPUT SELECT [PROP] = @r'"
    ' выполнени
    Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
    terrType = VBA.Trim(wrkResultSet("PROP"))

'    Stop
    If VBA.Trim(Sheets("Service").Range("A7").Text) = "" Then
        Call WRITE_TO_FILE(lcPath + "649M_1.txt", "Отчет", "649")
        Call WRITE_TO_FILE(lcPath + "650M_1.txt", "Отчет", "650")
        Call WRITE_TO_FILE(lcPath + "651M_1.txt", "Справочная_таблица", "651")
        On Error GoTo errror
        lnRes = Shell("arj a -e -y " + lcFileName + " " + lcPath + "649M_1.txt " + lcPath + "650M_1.txt " + lcPath + "651M_1.txt ")
    Else
        If Sheets("Service").Range("A7") = 2 Then
           Call WRITE_TO_DBF(lcPath + "65001M_1.dbf", "Отчет")
           Call WRITE_TO_DBF(lcPath + "65101M_1.dbf", "Справочная_таблица")
           On Error GoTo errror
           lnRes = Shell("arj a -e -y " + lcFileName + " " + lcPath + "64901M_1.dbf " + lcPath + "65001M_1.dbf " + lcPath + "65101M_1.dbf ")
        Else
           lcDate_end = VBA.Trim(Sheets("Service").Range("A19"))
           lcDate_end = VBA.Mid(lcDate_end, 7, 2) + "." + VBA.Mid(lcDate_end, 5, 2) + "." + VBA.Mid(lcDate_end, 1, 4)
           lcDate_end = VBA.Format(lcDate_end, "myy")

           Call WRITE_TO_DBF_F(lcPath + lcDate_end + "50.dbf", "Отчет")
           Call WRITE_TO_DBF_F(lcPath + lcDate_end + "51.dbf", "Справочная_таблица")
           On Error GoTo errror
           lnRes = Shell("arj a -e -y " + lcFileName + " " + lcPath + lcDate_end + "50.dbf " + lcPath + lcDate_end + "51.dbf ")
        End If
    End If
    
    LockWindowUpdate (0)
    Application.ScreenUpdating = True

    Close #2
    'заархивировать
    'Stop
    'Shell ("erase " + lcFileName)
    'call msgBox("arj a -e -y " + lcFileName + " " + lcPath + "650M_1.txt " + lcPath + "651M_1.txt " + lcPath + "652M_1.txt")
    'Shell ("arj a -e -y " + lcFileName + " " + lcPath + "650M_1.txt " + lcPath + "651M_1.txt " + lcPath + "652M_1.txt")
    'call msgBox("Архив "+lcFileName+" успешно создан !",0,"")
'End If
Exit Sub
errror:
    MsgBox "Ошибка при создании архива", vbCritical, "Ошибка в программе"
    LockWindowUpdate (0)
    Application.ScreenUpdating = True
    Close #2
Exit Sub
doError:
    Call ERROR_EVENT("SVOD_TO_FILE")
End Sub

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

Set sheetsService = Sheets("Service")
Set sheetsReport = Sheets(razdel)

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

Open lcFileName For Output As #1

sheetsReport.Activate
' Формирование шапки
Call writeHead_svod(CodeForm)
' Формирование информативной части
With sheetsService.Range("KRIT_RAZDEL")
     lnColumn1 = .column
     lnRow1 = .row
End With

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

    
    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With
'Stop
    subRazdel = 1
    For nCnt = pnAddress_Row To 1 + sheetsService.Range("A9")
        If sheetsReport.Cells(nCnt, 1) <> 0 Then
            If subRazdel <> sheetsReport.Cells(nCnt, 2) Then
                subRazdel = sheetsReport.Cells(nCnt, 2)
                Print #1, "#"
                Print #1, "#@"
                Print #1, "ТБ = 0" + VBA.Trim(VBA.str(subRazdel))
'                Print #1, "#"
                Print #1, "#$"
            End If
            lcCodeStr = Replace_in_Str(getFullCode(nCnt), " ", "")
            If razdel <> "Отчет" Then 'раздробим код
                If sheetsReport.Cells(nCnt, 2) <> 5 Then
                    lcCodeStr = VBA.Left(lcCodeStr, VBA.Len(lcCodeStr) - 6) + "|" + VBA.Mid(lcCodeStr, VBA.Len(lcCodeStr) - 5, 3) + "|" + VBA.Right(lcCodeStr, 3)
                Else

                    lcCodeStr = VBA.Left(lcCodeStr, VBA.Len(lcCodeStr) - 9) + "|" + VBA.Mid(lcCodeStr, VBA.Len(lcCodeStr) - 8, 6) + "|" + VBA.Right(lcCodeStr, 3)
                End If
            End If
            lcCodeStr = VBA.Trim(VBA.Trim(lcCodeStr) & VBA.Space(IIf(30 - VBA.Len(VBA.Trim(lcCodeStr)) > 0, 30 - VBA.Len(VBA.Trim(lcCodeStr)), 0)))
            lnSumma = 0
            lcValue = ""
            For nCntCol = pnAddress_Col + IIf(CodeForm = "650", 6, 0) To pnAddress_Col + sheetsService.Range("A10") - 1 + IIf(CodeForm = "649", -3, 0)
                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(20 - VBA.Len(tempStr)) + tempStr
            Next
            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
        End If
    Next

' Формирование заключительной части
Call writeFooter_svod
Close #1
'Print #1, Application.Names("WRITE_3").RefersToRange.Text
Application.StatusBar = False
'oldSheets.Activate
'LockWindowUpdate (0)
'Application.ScreenUpdating = True


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

Sub WRITE_TO_DBF(lcFileName As String, razdel 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, lcDate As String, str As String
Dim tempStr As String, row As Integer
Dim ofk As String
Dim lcDate_end As String
Dim klCol As Integer, kstCol As Integer
    On Error GoTo doError
    Application.StatusBar = "Подождите ... Идет запись в файл"
    
    Set sheetsService = Sheets("Service")
    Set sheetsReport = Sheets(razdel)
    
    sheetsReport.Activate
    
    lcDate_end = VBA.Trim(Sheets("Service").Range("A19"))
    lcDate_end = DateAdd("d", 1, VBA.Mid(lcDate_end, 7, 2) + "." + VBA.Mid(lcDate_end, 5, 2) + "." + VBA.Mid(lcDate_end, 1, 4))
    lcDate_end = VBA.Format(lcDate_end, "yyyyddmm")

    klCol = sheetsReport.Range("KL_" + VBA.Trim(VBA.str(Sheets("Service").Range("B20")))).column
    kstCol = sheetsReport.Range("KST_" + VBA.Trim(VBA.str(Sheets("Service").Range("B20")))).column

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

    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With

    With sheetsService
         lnOutEmptyBars = .Range("C14")
    End With
    
'    Stop
    row = 2
    ofk = VBA.Left(VBA.Trim(Sheets("Service").Range("C11").Text), 3)
    For nCnt = pnAddress_Row To 1 + sheetsService.Range("A9")
        If sheetsReport.Cells(nCnt, 1) <> 0 Then
            lcCodeStr = getFullCode(nCnt)
            'If Razdel = "Справочная_таблица" Then lcCodeStr = VBA.Left(lcCodeStr, VBA.Len(lcCodeStr) - 3)
            lnSumma = 0
            For nCntCol = pnAddress_Col To pnAddress_Col + sheetsService.Range("A10") - 1
                lnSumma = lnSumma + VBA.Abs(sheetsReport.Cells(nCnt, nCntCol).Value)
                Sheets("DBF_EXCHANGE").Cells(row, 8 + nCntCol - pnAddress_Col) = sheetsReport.Cells(nCnt, nCntCol).Value
            Next
            For nCntCol = pnAddress_Col + sheetsService.Range("A10") To pnAddress_Col + 8
                Sheets("DBF_EXCHANGE").Cells(row, 8 + nCntCol - pnAddress_Col) = 0
            Next
            If lnOutEmptyBars = 1 Or lnSumma <> 0 Then
                Sheets("DBF_EXCHANGE").Cells(row, 1) = terrType
                Sheets("DBF_EXCHANGE").Cells(row, 2) = ofk
                Sheets("DBF_EXCHANGE").Cells(row, 3) = lcDate_end
                Sheets("DBF_EXCHANGE").Cells(row, 5).NumberFormat = "@"
                Sheets("DBF_EXCHANGE").Cells(row, 5) = lcCodeStr + " "
                Sheets("DBF_EXCHANGE").Cells(row, 4) = IIf(razdel = "Отчет", "650", "651")
                Sheets("DBF_EXCHANGE").Cells(row, 6) = sheetsReport.Cells(nCnt, klCol).Value
                Sheets("DBF_EXCHANGE").Cells(row, 7) = sheetsReport.Cells(nCnt, kstCol).Value
                row = row + 1
            End If
        End If
    Next
    
    Sheets("DBF_EXCHANGE").Visible = True
    Sheets("DBF_EXCHANGE").Activate
    Application.DisplayAlerts = False

    If razdel = "Отчет" Then
       'сохранение
       With Sheets("DBF_EXCHANGE")
           .Range(.Cells(1, 1), .Cells(row - 1, 13)).Select '6 + sheetsService.Range("A10")
           Sheets("DBF_EXCHANGE").Range(Sheets("DBF_EXCHANGE").Cells(2, 4), Sheets("DBF_EXCHANGE").Cells(row, 4)) = "649"
           ActiveWorkbook.SaveAs fileName:=Replace_in_Str(lcFileName, "650", "649"), FileFormat:=xlDBF4, CreateBackup:=False
           .Range(.Cells(2, 8), .Cells(row, 13)).Delete Shift:=xlToLeft '6 + sheetsService.Range("A10")
           .Range(.Cells(1, 1), .Cells(row - 1, 10)).Select '6 + sheetsService.Range("A10")
           Sheets("DBF_EXCHANGE").Range(Sheets("DBF_EXCHANGE").Cells(2, 4), Sheets("DBF_EXCHANGE").Cells(row, 4)) = "650"
           ActiveWorkbook.SaveAs fileName:=lcFileName, FileFormat:=xlDBF4, CreateBackup:=False

       End With
    Else
       'сохранение
       With Sheets("DBF_EXCHANGE")
           .Range(.Cells(1, 1), .Cells(row - 1, 10)).Select '6 + sheetsService.Range("A10")
           ActiveWorkbook.SaveAs fileName:=lcFileName, FileFormat:=xlDBF4, CreateBackup:=False
           .Range(.Cells(2, 1), .Cells(row - 1, 10)).Delete '6 + sheetsService.Range("A10")
       End With
    End If
    
    Application.DisplayAlerts = True
    Sheets("DBF_EXCHANGE").Visible = False
Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_DBF")
End Sub

Sub WRITE_TO_DBF_F(lcFileName As String, razdel 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, lcDate As String, str As String
Dim tempStr As String, row As Integer
Dim ofk As String
Dim lcDate_end As String
Dim klCol As Integer, kstCol As Integer
    On Error GoTo doError
    Application.StatusBar = "Подождите ... Идет запись в файл"
    
    Set sheetsService = Sheets("Service")
    Set sheetsReport = Sheets(razdel)
    
    sheetsReport.Activate
    
    klCol = sheetsReport.Range("KL_" + VBA.Trim(VBA.str(Sheets("Service").Range("B20")))).column
    kstCol = sheetsReport.Range("KST_" + VBA.Trim(VBA.str(Sheets("Service").Range("B20")))).column

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

    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With

    With sheetsService
         lnOutEmptyBars = .Range("C14")
    End With
    
'    Stop
    row = 2
    ofk = VBA.Left(VBA.Trim(Sheets("Service").Range("C11").Text), 3)
    For nCnt = pnAddress_Row To 1 + sheetsService.Range("A9")
        If sheetsReport.Cells(nCnt, 1) <> 0 Then
            lcCodeStr = getFullCode(nCnt)
            'If Razdel = "Справочная_таблица" Then lcCodeStr = VBA.Left(lcCodeStr, VBA.Len(lcCodeStr) - 3)
            lnSumma = 0
            For nCntCol = pnAddress_Col To pnAddress_Col + sheetsService.Range("A10") - 1
                lnSumma = lnSumma + VBA.Abs(sheetsReport.Cells(nCnt, nCntCol).Value)
                Sheets("DBF_EXCHANGE_F").Cells(row, 6 + nCntCol - pnAddress_Col) = sheetsReport.Cells(nCnt, nCntCol).Value
            Next
            For nCntCol = pnAddress_Col + sheetsService.Range("A10") To pnAddress_Col + 8
                Sheets("DBF_EXCHANGE_F").Cells(row, 6 + nCntCol - pnAddress_Col) = 0
            Next
            If lnOutEmptyBars = 1 Or lnSumma <> 0 Then
                Sheets("DBF_EXCHANGE_F").Cells(row, 1) = terrType
                Sheets("DBF_EXCHANGE_F").Cells(row, 2) = ofk
                Sheets("DBF_EXCHANGE_F").Cells(row, 3) = sheetsReport.Cells(nCnt, klCol).Value
                Sheets("DBF_EXCHANGE_F").Cells(row, 4) = sheetsReport.Cells(nCnt, kstCol).Value
                Sheets("DBF_EXCHANGE_F").Cells(row, 5).NumberFormat = "@"
                Sheets("DBF_EXCHANGE_F").Cells(row, 5) = lcCodeStr + " "
                row = row + 1
            End If
        End If
    Next
    
    Sheets("DBF_EXCHANGE_F").Visible = True
    Sheets("DBF_EXCHANGE_F").Activate
    Application.DisplayAlerts = False
    'сохранение
    With Sheets("DBF_EXCHANGE_F")
        .Range(.Cells(1, 1), .Cells(row - 1, 14)).Select '6 + sheetsService.Range("A10")
        ActiveWorkbook.SaveAs fileName:=lcFileName, FileFormat:=xlDBF4, CreateBackup:=False
        .Range(.Cells(2, 1), .Cells(row - 1, 14)).Delete '6 + sheetsService.Range("A10")
    End With
    
    Application.DisplayAlerts = True
    Sheets("DBF_EXCHANGE_F").Visible = False
Exit Sub
doError:
    Call ERROR_EVENT("WRITE_TO_DBF_F")
End Sub
