Attribute VB_Name = "INFILE"
Option Explicit
' -------------------------------------------------------------------------------------------------------
#If Win64 Then
    Public Declare PtrSafe Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
    Public Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Public Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#Else
    Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
    Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If


Public Const KEY_QUERY_VALUE = &H8
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const ERROR_SUCCESS = 0&
Global Const ERROR_NO_MORE_ITEMS = 259
' -------------------------------------------------------------------------------------------------------
Public lineNum As Integer, terrType As String, inputErrList As String, fileComment As String
Public OldRazdel As String
Public OldBK As String
' -------------------------------------------------------------------------------------------------------
' sType = 0 - строка с данными
' sType = 1 - строка с номером раздела
' sType = 2 - строка не с номером раздела но с "="
' sType = 3 - строка с "INN", "ИНН"
' sType = 4 - строка с "ДТ"
' sType = 5 - строка с "УК"
' sType = 6 - строка с "КБП"
' sType = 7 - строка с "ИСТ"
' sType = 8 - строка с "СОНО"
' sType = -1 - конец файла
' -------------------------------------------------------------------------------------------------------
' Функция чтения строки с принимаемого файла
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function ReadLine(Optional ByRef sType As Integer) As String
Dim s As String, temp As String

   On Error GoTo doError
readNext:
    If Not EOF(1) Then Line Input #1, s Else sType = -1: ReadLine = s: Exit Function
    s = VBA.Trim(s)
    s = Replace_in_Str(s, vbTab, "")
    s = Replace_in_Str(s, vbNullChar, "")
    s = Replace_in_Str(s, vbBack, "")
    lineNum = lineNum + 1
    sType = 0
    If s = "" Or VBA.Left$(s, 1) = "*" Then GoTo readNext
    If VBA.InStr(1, s, "=") <> 0 Then 'не строка с данными
        sType = 2
        temp = VBA.Trim(Replace_in_Str(Sheets("Service").Range("B51"), " ", ""))
        If temp = "" Then temp = "РД=" Else temp = Replace_in_Str(temp, "%razdel", "")
        If VBA.InStr(s, convert_dos_win("ВИД", 1)) <> 0 Or VBA.InStr(s, "ВИД") <> 0 Or VBA.InStr(s, convert_dos_win("ПРД", 1)) <> 0 Or VBA.InStr(s, "ПРД") <> 0 Or VBA.InStr(s, convert_dos_win("КОДФ", 1)) <> 0 Or VBA.InStr(s, "КОДФ") <> 0 Then sType = 0:  GoTo readNext
        If VBA.InStr(s, convert_dos_win("ТБ", 1)) <> 0 Or VBA.InStr(s, "ТБ") <> 0 Then sType = 1
        If VBA.InStr(Replace_in_Str(s, " ", ""), temp) <> 0 Or VBA.InStr(Replace_in_Str(s, " ", ""), convert_dos_win(temp, 1)) <> 0 Then sType = 1
        If VBA.InStr(s, "INN") <> 0 Or VBA.InStr(s, "ИНН") <> 0 Or VBA.InStr(s, convert_dos_win("ИНН", 1)) <> 0 Then sType = 3
        If VBA.InStr(s, "KBP") <> 0 Or VBA.InStr(s, "КБП") <> 0 Or VBA.InStr(s, convert_dos_win("КБП", 1)) <> 0 Then sType = 6
        If VBA.InStr(s, convert_dos_win("УК", 1)) <> 0 Or VBA.InStr(s, "УК") <> 0 Then sType = 5
        If VBA.InStr(s, convert_dos_win("ДТ", 1)) <> 0 Or VBA.InStr(s, "ДТ") <> 0 Then sType = 4
        If VBA.InStr(s, convert_dos_win("ИСТ", 1)) <> 0 Or VBA.InStr(s, "ИСТ") <> 0 Then sType = 7
        If VBA.InStr(s, convert_dos_win("СОНО", 1)) <> 0 Or VBA.InStr(s, "СОНО") <> 0 Then sType = 8
    End If
    ReadLine = s
Exit Function
doError:
    Call ERROR_EVENT("ReadLine")
End Function
' -------------------------------------------------------------------------------------------------------
' Функция записи дат для отчета
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function Formate_date(ByVal lcYear As String, ByVal lcMonth As String, ByRef lnCodeError As Variant, Optional lcDay As String = "")
Dim lcDate, lcBeginDate, lcEndDate As String
Dim SheetsService As Object
Dim Format_date

    On Error GoTo doError
    Set SheetsService = Sheets("Service")
    lcDate = IIf(lcDay = "", "01", lcDay) & "." & lcMonth & "." & lcYear
    ' Проверка значений
    If VBA.Len(lcMonth) > 2 Or VBA.Len(lcYear) > 4 Then ' неправильные значения
        lnCodeError = 8
        Format_date = False
        Exit Function
    End If

    If IsDate(lcDate) Then
        If SheetsService.Range("B5") <> "дневная" Then
            If VBA.Val(lcMonth) = 1 And (lcDay = "" Or lcDay = "01") Then ' начало года
                lcBeginDate = VBA.Trim(VBA.str(VBA.Year(lcDate) - 1)) & "0101"
                lcEndDate = VBA.Format(VBA.DateAdd("D", -1, lcDate), "yyyymmdd")
            Else
                lcBeginDate = VBA.Trim(VBA.str(VBA.Year(lcDate))) & "0101"
                lcEndDate = VBA.Format(VBA.DateAdd("D", -1, lcDate), "yyyymmdd")
            End If
        Else
            lcBeginDate = VBA.Format(lcDate, "yyyymmdd")
            lcEndDate = VBA.Format(lcDate, "yyyymmdd")
        End If
        Formate_date = True
        SheetsService.Range("A18") = lcBeginDate
        SheetsService.Range("A19") = lcEndDate
        SheetsService.Range("B1") = lcEndDate
    Else ' Не является датой запись файла не возможна
        lnCodeError = 8
        Formate_date = False
    End If
    Exit Function
doError:
    Call ERROR_EVENT("FormatDate")
End Function
' -------------------------------------------------------------------------------------------------------
' Функция проверки существования корреспондента
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function Check_Corr(ByVal lcCodeRegion, lnCodeError, Optional INN As String = "", Optional KBP As String = "", Optional IST As String = "", Optional SONO As String = "") As Boolean
Dim SheetsService As Object
Dim cSql As String
Dim oRecordSet As Object

    On Error GoTo doError
    Set SheetsService = Sheets("Service")
    On Error GoTo ttt
    If oAdoConnect Is Nothing Then
ttt:    Call AdoSrvConnect
    End If
    If INN = "" And KBP = "" And IST = "" And SONO = "" Then
        cSql = "SELECT c.link,inn,sname FROM s_corr_app a, s_corr c " + _
                " WHERE a.object=dbo.obj_id(''COLUMN_DICT_OFK_CODE'') " + _
                "       and a.link_up=c.link and right(a.VALUE,2)=" + "''" + VBA.Trim(lcCodeRegion) + "'' " + _
                "       and c.LINK IN (SELECT TCD.CORR FROM GET_VAL_REC(''" + Sheets("Service").Range("A15").Text + "'',''USE_REPORT_CORR'') TFD, T_CORR_DICT TCD WHERE  TFD.RECORD = TCD.CORR_DICT)"
    End If
    If INN <> "" Then
        cSql = "SELECT link,inn,sname FROM s_corr c WHERE c.inn = " + "''" + VBA.Trim(INN) + "''"
    End If
    If KBP <> "" Then
        cSql = "SELECT link,inn,sname FROM s_corr c WHERE c.code = " + "''" + VBA.Trim(KBP) + "''"
    End If
    If IST <> "" Then
        cSql = "SELECT TOP 1 c.link,inn,sname FROM s_corr_app a,s_corr c " + _
                " WHERE  a.object=dbo.obj_id(''COLUMN_DICT_OFK_CODE'') " + _
                "        and a.link_up=c.link and right(a.VALUE,3)=" + "''" + VBA.Trim(IST) + "'' " + _
                "        and c.LINK IN (SELECT TCD.CORR FROM GET_VAL_REC(''" + Sheets("Service").Range("A15").Text + "'',''USE_REPORT_CORR'') TFD, T_CORR_DICT TCD WHERE  TFD.RECORD = TCD.CORR_DICT)" + _
                " UNION ALL " + _
                "SELECT c.link,inn,sname FROM s_corr c " + _
                " WHERE  c.DEPARTMENT IN(SELECT SK.LINK FROM S_KBK SK WHERE CODE = " + "''" + VBA.Trim(IST) + "'' AND SK.OBJECT = dbo.obj_id(''DICTIONARY_DEPARTMENT''))" + _
                "        and c.LINK IN (SELECT TCD.CORR FROM GET_VAL_REC(''" + Sheets("Service").Range("A15").Text + "'',''USE_REPORT_CORR'') TFD, T_CORR_DICT TCD WHERE  TFD.RECORD = TCD.CORR_DICT)"
    End If
    If SONO <> "" Then
        cSql = "SELECT c.link,c.inn,c.sname FROM s_corr c, s_corr_app ca " + _
                " WHERE ca.object = dbo.obj_id(''COLUMN_DICT_IMNS_SONO'') and ca.link_up = c.link and left(ca.value, 4) = " + "''" + VBA.Trim(SONO) + "''"
    End If
    
    Set oRecordSet = CreateObject("ADODB.RecordSet")
    oRecordSet.Open "A_EXEC ' " + cSql + " '", oAdoConnect, 2, 1, 1
    ' получим LINK  объекта
    If oRecordSet.EOF = False Then ' корреспондент есть
        Check_Corr = True
        ' заполнение таблицы с данными
        Sheets("SQLDATA2").Cells(2, 1).CopyFromRecordset oRecordSet
        SheetsService.Range("A16") = Sheets("SQLDATA2").Cells(2, 1).Value
        SheetsService.Range("B2") = Sheets("SQLDATA2").Cells(2, 2) + " - " + Sheets("SQLDATA2").Cells(2, 3)
        lnCodeError = 0
        If INN = "" And KBP = "" And IST = "" And SONO = "" And VBA.Left(VBA.Trim(lcCodeRegion), 2) <> VBA.Left(VBA.Trim(fName), 2) Then
            skiped_str = skiped_str + "Несоответствие имени файла и содержимого файла (УК = " + lcCodeRegion + ", в имени файла корреспондент " + VBA.Left(fName, 2) + ")" + vbNewLine
        End If
    Else
        Check_Corr = False
        lnCodeError = 7
    End If
Exit Function
doError:
    Call ERROR_EVENT("CheckCorr")
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура контроля документа по формулам контроля
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub CONTROL_REPORT_FROM_FILE(Optional filename As String = "")
Dim i, pnWhatCalculate, nCnt, nCntCol, lnCellLink, lnRowCell, lnColumnCell As Integer
Dim hWnd, lnCountAllRow, lnCountAllColumn, lbResult, lnColumn1, lnRow1 As Long
Dim lbError, flag As Boolean
Dim lSheetsReport, lSheetsService, oldSheet As Object

    Set lSheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    Set lSheetsService = Sheets("Service")
    lnCountAllRow = lSheetsService.Range("A9")
    lnCountAllColumn = lSheetsService.Range("A10")

    'Флаг наличия расхождения
    lbError = False
    ' защита листа - снять
    lSheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Sheets("Service").Range("A37").Value = 1
    ' Контроль всего документа
    With ThisWorkbook.Sheets("Service")
        pnAddress_Row = .Range("C5")
        pnAddress_Col = .Range("C6")
    End With
    errList = errList + "  Анализ контрольных соотношений: " + vbCrLf
    Call addHead

    flag = False
                    
    With lSheetsService.Range("KRIT_RAZDEL")
        lnColumn1 = .column
        lnRow1 = .row
    End With
    Set oldSheet = Application.ActiveWorkbook.Sheets(lSheetsService.Range("B19").Text)
    If filename <> "" Then lSheetsService.Range("A30") = 1
    For i = 1 To lSheetsService.Range("B23")
        ' установим страницу зададим критерий
        lSheetsService.Cells(lnRow1 + 1, lnColumn1) = i
        If lSheetsService.Range("B23") = 1 Then
            Set lSheetsReport = Application.ActiveWorkbook.Sheets(lSheetsService.Range("B19").Text)
        Else
            Set lSheetsReport = Application.ActiveWorkbook.Sheets(lSheetsService.Cells(lnRow1 + 3, lnColumn1).Text)
        End If
        lSheetsReport.Activate
        OldRazdel = i
        ' защита листа - снять
        lSheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False

        lnCountAllRow = lSheetsService.Range("A9")
        lnCountAllColumn = lSheetsService.Range("A10")
    
        With lSheetsService
            pnAddress_Row = .Range("C5")
            pnAddress_Col = .Range("C6")
        End With

        'проверим тип листа
        lSheetsService.Range(lSheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), lSheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 2)) = ""
        lSheetsService.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
        lSheetsService.Cells(KRIT_RAZDEL_ROW + 4, KRIT_RAZDEL_COLUMN).CALCULATE
    
        If VBA.Val(lSheetsService.Cells(KRIT_RAZDEL_ROW + 4, KRIT_RAZDEL_COLUMN).Text) <> 1 Then
            Call addHead
            For nCnt = pnAddress_Row To pnAddress_Row + lnCountAllRow + 1
                lnCellLink = lSheetsReport.Cells(nCnt, 1)
                If lnCellLink <> 0 Then
                    For nCntCol = 1 To lnCountAllColumn
                        lnColumnCell = nCntCol - 1 + pnAddress_Col
                        lbResult = CONTROL_CELL(lnCellLink, nCnt, lnColumnCell, OldRazdel, "")
                        If lbResult Then ' неправильно
                            lbError = True
                            flag = True
                        End If
                    Next
                End If
            Next
        End If
        ' защита листа - поставить
        lSheetsReport.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
    Next
    oldSheet.Activate

    If flag Then 'ошибка
        Sheets("Service").Range("A59") = 0
        errList = errList + " - обнаружены ошибки контроля " + vbCrLf
    Else
        lSheetsService.Range("A59") = 1
        errList = errList + " - ошибок контроля не обнаружено " + vbCrLf
    End If

    If filename <> "" Then
        Application.ScreenUpdating = True
    End If
    LockWindowUpdate (0)

End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура закрытия файла
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub closeFile()
        Close #2
End Sub
' -------------------------------------------------------------------------------------------------------
' Процедура формирования заголовка выгружаемого файла
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub writeHead()
    Dim lcDate As String
    
    lcDate = VBA.Trim(Sheets("Service").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")
    Print #1, convert_dos_win(Sheets("Service").Range("C13"), 1)
    If VBA.InStr(Sheets("Service").Range("C11").Text, "=") = 0 Then
        Print #1, convert_dos_win("УК=", 1) + VBA.Left(Sheets("Service").Range("C11").Text, 2)
    Else
        Print #1, convert_dos_win(VBA.Trim(Sheets("Service").Range("C11").Text), 1)
    End If
    Print #1, convert_dos_win("ДТ=", 1) + lcDate
End Sub
' -------------------------------------------------------------------------------------------------------
' ???
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub writeRazdel(n As Integer)
    Print #1, ""
    If Sheets("Service").Range("B51").Text <> "" Then Print #1, Replace_in_Str(convert_dos_win(Sheets("Service").Range("B51").Text, 1), "%razdel", VBA.Trim(VBA.str(n))) Else Print #1, convert_dos_win("РД=", 1) + VBA.Trim(VBA.str(n))
End Sub
' -------------------------------------------------------------------------------------------------------
' ????
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub writeHead_svod(Optional kf As String = "")
    Dim row As Integer, col As Integer
    Dim str As String, LookRange As Range, temp As Integer
    Dim lcDate_beg As String, lcDate_end As String, lcDate_tek As String
    
    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, "dd.mm.yyyy")
    lcDate_beg = VBA.Trim(Sheets("Service").Range("A18"))
    lcDate_beg = VBA.Mid(lcDate_beg, 7, 2) + "." + VBA.Mid(lcDate_beg, 5, 2) + "." + VBA.Mid(lcDate_beg, 1, 4)
    lcDate_beg = VBA.Format(lcDate_beg, "dd.mm.yyyy")
    lcDate_tek = VBA.Format(Date, "dd.mm.yyyy")
    If exists_name("HEAD_IN_OUT") Then
        row = Sheets("Service").Range("HEAD_IN_OUT").row
        col = Sheets("Service").Range("HEAD_IN_OUT").column
        While Sheets("Service").Cells(row, col) <> ""
            str = Sheets("Service").Cells(row, col).Text
            If VBA.InStr(1, str, "%TERR") <> 0 Then str = Replace_in_Str(str, "%TERR", VBA.Trim(Sheets("Service").Range("C11").Text))
            If VBA.InStr(1, str, "%TYPE") <> 0 Then str = Replace_in_Str(str, "%TYPE", terrType)
            If VBA.InStr(1, str, "%KF") <> 0 Then str = Replace_in_Str(str, "%KF", kf)
            If VBA.InStr(1, str, "%DEP") <> 0 Then str = Replace_in_Str(str, "%DEP", VBA.Trim(Sheets("SQLDATA2").Cells(1, 3).Text))
            If VBA.InStr(1, str, "%DIV") <> 0 Then str = Replace_in_Str(str, "%DIV", VBA.Trim(Sheets("SQLDATA2").Cells(1, 4).Text))
            If VBA.InStr(1, str, "%TGT") <> 0 Then str = Replace_in_Str(str, "%TGT", VBA.Trim(Sheets("SQLDATA2").Cells(1, 5).Text))
            If VBA.InStr(1, str, "%EXP") <> 0 Then str = Replace_in_Str(str, "%EXP", VBA.Trim(Sheets("SQLDATA2").Cells(1, 6).Text))
            If VBA.InStr(1, str, "%DATE_TEK") <> 0 Then str = Replace_in_Str(str, "%DATE_TEK", lcDate_tek)
            If VBA.InStr(1, str, "%DATE_BEG") <> 0 Then str = Replace_in_Str(str, "%DATE_BEG", lcDate_beg)
            If VBA.InStr(1, str, "%DATE_END") <> 0 Then str = Replace_in_Str(str, "%DATE_END", lcDate_end)
            If VBA.InStr(1, str, "%MONTH") <> 0 Then str = Replace_in_Str(str, "%MONTH", VBA.Right("0" + VBA.Trim(VBA.str(VBA.Month(lcDate_end) - 1)), 2))
            If VBA.InStr(1, str, "%STR_COUNT") <> 0 Then
                Set LookRange = Sheets("SQLDATA2").Columns(1).Find("", LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows)
                If Not LookRange Is Nothing Then
                    temp = LookRange.row - 1
                Else
                    temp = 0
                End If
                str = Replace_in_Str(str, "%STR_COUNT", VBA.Trim(VBA.str(temp)))
            End If
            If VBA.InStr(1, str, "%STRUCT") <> 0 Then
                With Sheets("Service")
                    'чистим критерий
                    .Range(.Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN), .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + KRIT_RAZDEL_COLUMNCOUNT - 1)) = ""
                    .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = .Range("B20")
                    .Cells(KRIT_RAZDEL_ROW + 7, KRIT_RAZDEL_COLUMN).CALCULATE
                    str = Replace_in_Str(str, "%STRUCT", VBA.Trim(.Cells(KRIT_RAZDEL_ROW + 7, KRIT_RAZDEL_COLUMN)))
                    .Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = ""
                End With
            End If
            Print #1, str
            Sheets("SQLDATA2").Visible = -1
            row = row + 1
        Wend
    Else
        Print #1, "Заголовок файла шаблона не настроен !!!"
    End If
End Sub
' -------------------------------------------------------------------------------------------------------
' ???
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub writeFooter_svod()
    Dim row As Integer, col As Integer, tempStr As String
    Dim str As String, LookRange As Range, temp As Integer
    Dim i As Integer
    
    If exists_name("FOOTER_IN_OUT") Then
        row = Sheets("Service").Range("FOOTER_IN_OUT").row
        col = Sheets("Service").Range("FOOTER_IN_OUT").column
        While Sheets("Service").Cells(row, col) <> ""
            'проверим маску
            If (Sheets("Service").Cells(row, col + 2) And (2 ^ (Sheets("Service").Range("B20") - 1))) <> 0 Then
                str = Sheets("Service").Cells(row, col) + IIf(Sheets("Service").Cells(row, col + 1) <> "", vbTab + Sheets("Service").Cells(row, col + 1), "")
                If VBA.InStr(1, str, "%STR_COUNT") <> 0 Then
                    i = Sheets("Service").Range("FOOTER_IN_OUT").row
                    temp = 0
                    While Sheets("Service").Cells(i, col) <> ""
                        If (Sheets("Service").Cells(i, col + 2) And (2 ^ (Sheets("Service").Range("B20") - 1))) <> 0 Then temp = temp + 1
                        i = i + 1
                    Wend
                    str = Replace_in_Str(str, "%STR_COUNT", VBA.Trim(VBA.str(IIf(temp - 2 < 0, 0, temp - 2))))
                End If
                If VBA.InStr(1, str, """ED_IZM""") <> 0 Then
                    Select Case Sheets("Service").Range("A28").Value
                        Case 1
                            str = str + vbTab + """руб"""
                        Case 2
                            str = str + vbTab + """тыс руб"""
                        Case 3
                            str = str + vbTab + """млн руб"""
                        Case 4
                            str = str + vbTab + """млрд руб"""
                    End Select
                End If
                If VBA.InStr(1, str, """GR""") <> 0 Then str = str + vbTab + """"""
                If VBA.InStr(1, str, """OKPO""") <> 0 Then str = str + vbTab + """"""
                If VBA.InStr(1, str, """PPP""") <> 0 Then str = str + vbTab + """" + VBA.Trim(Sheets("SQLDATA2").Cells(1, 3).Text) + """"
                If VBA.InStr(1, str, """RUK""") <> 0 Then str = str + vbTab + """"""
                If VBA.InStr(1, str, """GLB""") <> 0 Then str = str + vbTab + """"""
                
                Print #1, str
            End If
            row = row + 1
        Wend
    Else
        Print #1, "Заголовок файла шаблона не настроен !!!"
    End If
End Sub
' -------------------------------------------------------------------------------------------------------
' ???
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function readHead() As Integer
    Dim row As Integer, col As Integer, bool As Boolean, lSheetsReport As Worksheet
    Dim rStr As String, str As String, LookRange As Range, temp As Integer, i As Integer, j As Integer
    Dim lcDate_beg As String, lcDate_end As String, lcDate_tek As String
    Dim struct As String
    If exists_name("HEAD_IN_OUT") Then
        'заголовок формы
        rStr = VBA.UCase(ReadLine(j))
        
        row = Sheets("Service").Range("HEAD_IN_OUT").row
        col = Sheets("Service").Range("HEAD_IN_OUT").column
        'найдем соответствующий лист
        Sheets("Service").Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN + 1) = ""
        For i = 1 To Sheets("Service").Range("B23")
            ' установим страницу
            ' зададим критерий
            Sheets("Service").Cells(KRIT_RAZDEL_ROW + 1, KRIT_RAZDEL_COLUMN) = i
            If Sheets("Service").Range("B23") = 1 Then
                Set lSheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Range("B19").Text)
            Else
                Sheets("Service").Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).CALCULATE
                Set lSheetsReport = Application.ActiveWorkbook.Sheets(Sheets("Service").Cells(KRIT_RAZDEL_ROW + 3, KRIT_RAZDEL_COLUMN).Text)
            End If
            lSheetsReport.Activate
            If Sheets("Service").Cells(row, col).Text = rStr Then GoTo ok1
        
        Next
        readHead = 1
        inputErrList = inputErrList + "Неизвестный код формы """ + rStr + """ !" + vbCrLf
        Exit Function
        
ok1:
        Sheets("Service").Cells(KRIT_RAZDEL_ROW + 7, KRIT_RAZDEL_COLUMN).CALCULATE
        struct = Sheets("Service").Cells(KRIT_RAZDEL_ROW + 7, KRIT_RAZDEL_COLUMN)
        borderCount = chr_count(struct, ",")
        row = row + 1
'       stop
        While Sheets("Service").Cells(row, col) <> ""
            rStr = ReadLine(j)
            str = Sheets("Service").Cells(row, col).Text
            If VBA.InStr(1, str, "%TERR") <> 0 Then
                'правый символ не анализируем
                If Not Check_Corr(VBA.Left(rStr, VBA.Len(rStr) - 1), j) Then
                    readHead = j
                    Exit Function
                End If
            End If
            If VBA.InStr(1, str, "%DEP") <> 0 Then
                If VBA.Len(rStr) = 3 Then
                    Sheets("Service").Range("B28") = rStr
                Else
                    inputErrList = inputErrList + "Неверный код ведомства """ + rStr + """, строка " + VBA.str(lineNum) + vbCrLf
                End If
            End If
            If VBA.InStr(1, str, "%DIV") <> 0 Then
                If VBA.Len(rStr) = 4 Then
                    Sheets("Service").Range("B27") = rStr
                Else
                    inputErrList = inputErrList + "Неверный код подраздела """ + rStr + """, строка " + VBA.str(lineNum) + vbCrLf
                End If
            End If
            If VBA.InStr(1, str, "%TGT") <> 0 Then
                If VBA.Len(rStr) = 3 Then
                    Sheets("Service").Range("B29") = rStr
                Else
                    inputErrList = inputErrList + "Неверный код целевой статьи """ + rStr + """, строка " + VBA.str(lineNum) + vbCrLf
                End If
            End If
            If VBA.InStr(1, str, "%EXP") <> 0 Then
                If VBA.Len(rStr) = 5 Then
                    Sheets("Service").Range("B30") = rStr
                Else
                    inputErrList = inputErrList + "Неверный код вида расхода """ + rStr + """, строка " + VBA.str(lineNum) + vbCrLf
                End If
            End If
            If VBA.InStr(1, str, "%DATE_BEG") <> 0 Then
                If IsDate(rStr) Then
                    lcDate_beg = rStr
                Else
                    readHead = 8
                    Exit Function
                End If
                Sheets("Service").Range("A18") = Year(lcDate_beg) & IIf(Month(lcDate_beg) < 10, "0", "") & Month(lcDate_beg) & IIf(Day(lcDate_beg) < 10, "0", "") & Day(lcDate_beg)
            End If
            If VBA.InStr(1, str, "%DATE_END") <> 0 Then
                If IsDate(rStr) Then
                    lcDate_end = rStr
                Else
                    readHead = 8
                    Exit Function
                End If
                lcDate_end = VBA.DateAdd("Y", -1, lcDate_end)
                Sheets("Service").Range("A19") = Year(lcDate_end) & IIf(Month(lcDate_end) < 10, "0", "") & Month(lcDate_end) & IIf(Day(lcDate_end) < 10, "0", "") & Day(lcDate_end)
            End If
            If VBA.InStr(1, str, "%STR_COUNT") <> 0 Then dataLinesCount = VBA.Val(rStr)
            If VBA.InStr(1, str, "%STRUCT") <> 0 Then
                If Replace_in_Str(struct, " ", "") <> Replace_in_Str(rStr, " ", "") Then
                    inputErrList = inputErrList + "Неверный формат структуры отчета """ + rStr + """" + vbCrLf
                    readHead = 99
                    Exit Function
                End If
            End If
            row = row + 1
        Wend
    Else
         inputErrList = inputErrList + "Заголовок файла шаблона не настроен !!!" + vbCrLf
        readHead = 99
    End If
    readHead = 0
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура загрузки данных
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function LoadData(filename As String, Optional sheetName As String = "DBF_EXCHANGE") As Integer
Dim startRange As Range, qt As QueryTable, odbcDriver As String, odbcstr As String, n As Integer, wsd
Dim columnsCount As Integer, rowsCount As Integer
    LoadData = 0
    Application.StatusBar = "Загрузка рабочих данных..."
    Set wsd = Sheets(sheetName)
    wsd.Activate
    Set startRange = wsd.Cells(1, 1)
    odbcDriver = GetODBCDriver()
    dbPath = IIf(dbPath = "", ThisWorkbook.path + "\", dbPath)
    odbcstr = "ODBC;" + _
        "Driver=" + odbcDriver + ";" + _
        "UID=admin;SourceType=DBF;" + _
        "DefaultDir=" + dbPath + "\;" + _
        "DBQ=" + dbPath + "\;" + _
        "SourceDB=" + dbPath + "\;"
    Set qt = wsd.QueryTables.Add(odbcstr, _
        startRange, "SELECT * FROM " + filename)
    qt.BackgroundQuery = False
    qt.FieldNames = True
    On Error GoTo Err1
    qt.Refresh
    On Error GoTo 0
    columnsCount = qt.ResultRange.Columns.count
    rowsCount = qt.ResultRange.Rows.count - 1
    LoadData = columnsCount
    If LoadData = 0 Then
        qt.ResultRange.Columns.Delete
    Else
        LoadData = rowsCount
    End If
Exit Function
Err1:
    inputErrList = inputErrList + "Ошибка загрузки данных" + vbCrLf
    LoadData = 0
End Function

Function GetODBCDriver() As String
    Dim lcDriver As String, lcKey As String
    Dim hKey As Long, lnSize As Long, e As Long, i As Long
    Dim llFox As Boolean, llVisual As Boolean
    e = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI", 0, KEY_QUERY_VALUE, hKey)
    i = 0
    llFox = False
    llVisual = False
    Do
        lcKey = Space(250)
        lnSize = Len(lcKey)
        e = RegEnumKey(hKey, i, lcKey, lnSize)
        If Trim(lcKey) <> "" Then
            lcDriver = Mid(Trim(lcKey), 1, Len(Trim(lcKey)) - 1)
            llFox = llFox Or lcDriver Like "Microsoft FoxPro Driver*"
            llVisual = llVisual Or lcDriver Like "Microsoft Visual FoxPro Driver*"
        End If
        i = i + 1
    Loop While e = ERROR_SUCCESS
    RegCloseKey hKey
    GetODBCDriver = IIf(llVisual, "Microsoft Visual FoxPro Driver", IIf(llFox, "Microsoft FoxPro Driver (*.dbf)", "Microsoft Visual FoxPro Driver"))
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура получения протокола
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function GetProtocol(Optional mode As Integer = 0) As String
    If mode = 0 Then
        GetProtocol = errList
        errList = ""
    End If
    If mode = 1 Then
        GetProtocol = inputErrList
        inputErrList = ""
    End If
    If mode = 2 Then
        GetProtocol = fileComment
        fileComment = ""
    End If
End Function
' -------------------------------------------------------------------------------------------------------
