Attribute VB_Name = "StringFunc"
Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
    Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
    Private Declare PtrSafe Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare PtrSafe Function GetSaveFileName Lib "COMDLG32.DLL" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
#Else
    Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
    Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
    Private Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetSaveFileName Lib "COMDLG32.DLL" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
#End If

Public Type ShortItemId
   cb As Long
   abID As Byte
End Type

Public Type ITEMIDLIST
   mkid As ShortItemId
End Type

Private Type OPENFILENAME
    lStructSize       As Long
    hwndOwner         As Long
    hInstance         As Long
    lpstrFilter       As String
    lpstrCustomFilter As String
    nMaxCustFilter    As Long
    nFilterIndex      As Long
    lpstrFile         As String
    nMaxFile          As Long
    lpstrFileTitle    As String
    nMaxFileTitle     As Long
    lpstrInitialDir   As String
    lpstrTitle        As String
    Flags             As Long
    nFileOffset       As Integer
    nFileExtension    As Integer
    lpstrDefExt       As String
    lCustData         As Long
    lpfnHook          As Long
    lpTemplateName    As String
End Type
' -------------------------------------------------------------------------------------------------------
' Функция возвращает путь к имени файла
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function GetFileFromAPI(defPath As String, Optional sExt As String = "*", Optional mode As Integer = 0) As String
Dim OFN As OPENFILENAME
Dim n As Integer
With OFN
    .lpstrInitialDir = defPath
    .lStructSize = Len(OFN)
    .nMaxFile = 260
    .lpstrFile = VBA.String(.nMaxFile - 1, 0)
    .lpstrFilter = "*." + sExt + VBA.Chr(0) + "*." + sExt + VBA.Chr(0)
    If mode = 0 Then
        If GetSaveFileName(OFN) <> 0 Then
            n = InStr(.lpstrFile, vbNullChar)
            GetFileFromAPI = VBA.Left(.lpstrFile, n - 1)
        Else
            GetFileFromAPI = ""
        End If
    Else
        If GetOpenFileName(OFN) <> 0 Then
            n = InStr(.lpstrFile, vbNullChar)
            GetFileFromAPI = VBA.Left(.lpstrFile, n - 1)
        Else
            GetFileFromAPI = ""
        End If
    End If
End With
End Function
' -------------------------------------------------------------------------------------------------------
' Функция замены
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function Replace_in_Str(ByVal lcTemplate As String, _
                            ByVal strWhat As String, _
                            ByVal strOnWhat As String) As String
Dim lnStartBegin As Integer, lnStartEnd As Integer, lnLenWhat As Integer
Dim lcExprLeft As String, lcExprRight As String
Dim TEMPLATE As String
    
On Error GoTo doError
    
TEMPLATE = lcTemplate
While VBA.InStr(1, TEMPLATE, strWhat, vbTextCompare) <> 0
    lnLenWhat = VBA.Len(strWhat)
    lnStartBegin = VBA.InStr(1, TEMPLATE, strWhat, vbTextCompare)
    lnStartEnd = lnStartBegin + lnLenWhat
    lcExprLeft = VBA.Left(TEMPLATE, lnStartBegin - 1)
    lcExprRight = VBA.Right(TEMPLATE, VBA.Len(TEMPLATE) - lnStartEnd + 1)
    TEMPLATE = lcExprLeft + strOnWhat + lcExprRight
Wend
Replace_in_Str = TEMPLATE

Exit Function
doError:
    Call ERROR_EVENT("Replace_in_Str")

End Function
' -------------------------------------------------------------------------------------------------------
' Количество заданных символов в строке
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function chr_count(str As String, ch As String) As Integer
Dim i As Integer, out As Integer, l As Integer
    out = 0
    l = 1 'len(ch)
    For i = 1 To VBA.Len(str)
        If VBA.Mid$(str, i, l) = ch Then out = out + 1
    Next
    chr_count = out
End Function
' -------------------------------------------------------------------------------------------------------
' Функция отсечения последних нулей
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function TRUNCATE_00(ByVal lcValue As String) As String
Dim lnLenStr As Long, nCnt As Long, lcChar As String
    
    On Error GoTo doError
    lnLenStr = VBA.Len(lcValue)
    For nCnt = 1 To lnLenStr
        lcChar = VBA.Mid("1" + lcValue, lnLenStr + 2 - nCnt, 1)
        If lcChar <> "0" Then
            Exit For
        End If
    Next
    TRUNCATE_00 = IIf(lnLenStr + 1 = nCnt, "0", VBA.Left(lcValue, lnLenStr + 1 - nCnt))
Exit Function
doError:
    Call ERROR_EVENT("TRUNCATE_00")
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура возвращает кол-во вхождений до встречи определенного символа
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function OccurInStop(strSrc As String, strSearch1 As String, strSearch2 As String) As Long
Dim iCurrent As Long, jCurrent As Long, iNext As Long, old As Long
Dim lngRet As Long
Dim lbExists As Boolean
Dim nCnt As Integer
Dim leftC, rightC As Integer
    
    On Error GoTo doError
    nCnt = 1
    lbExists = False
    iCurrent = VBA.InStr(strSrc, strSearch1) ' Позиция ")" - первая
    jCurrent = VBA.InStr(strSrc, strSearch2) ' Позиция "(" - первая
    iNext = VBA.InStr(iCurrent + 1, strSrc, strSearch1, vbTextCompare)
    If iNext = 0 Or iNext > jCurrent Then
        OccurInStop = jCurrent
        Exit Function
    End If
    While Not lbExists
        iNext = VBA.InStr(iNext + 1, strSrc, strSearch1, vbTextCompare) ' Следующая позиция ")"
        nCnt = nCnt + 1
        If iNext > jCurrent Or iNext = 0 Then
            jCurrent = OccurInPos(strSrc, strSearch2, nCnt + 1)
            lbExists = True
        End If
    Wend
    OccurInStop = jCurrent
Exit Function
doError:
    Call ERROR_EVENT("OccurInStop")
End Function
' -------------------------------------------------------------------------------------------------------
' Процедура возвращения позиции по номеру вхождения
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function OccurInPos(strSrc As String, strSearch As String, ByVal nNum As Long) As Long
Dim i As Long
Dim lngRet As Long
    
    On Error GoTo doError
    i = VBA.InStr(strSrc, strSearch)
    lngRet = 1
    Do While lngRet < nNum
        i = VBA.InStr(i + 1, strSrc, strSearch)
        lngRet = lngRet + 1
    Loop
    OccurInPos = i
Exit Function
doError:
    Call ERROR_EVENT("OccurInPos")
End Function
' -------------------------------------------------------------------------------------------------------
' Определяет кол-во вхождений одной строки (символа) в другой строке (символе)
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function Occur(strSrc As String, strSearch As String) As Long
 Dim i As Long
 Dim lngRet As Long
    On Error GoTo doError
    i = VBA.InStr(strSrc, strSearch)
    lngRet = 0
    Do While i > 0
        i = VBA.InStr(i + 1, strSrc, strSearch)
        lngRet = lngRet + 1
    Loop
    Occur = lngRet
Exit Function
doError:
    Call ERROR_EVENT("Occur")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function MkChar(P_Nomeri As Long, P_Count As Long)
Dim ret, Tran As String
Dim X As Long
    
    On Error GoTo doError
    Tran = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    ret = ""
    X = P_Nomeri
    Do While X <> 0
        ret = Mid$(Tran, (X Mod 36) + 1, 1) + ret
        X = Int(X / 36)
    Loop
If VBA.Len(ret) > P_Count Then
   MkChar = Space$(P_Count)
Else
   MkChar = PadL((ret), P_Count, "0")
End If
Exit Function
doError:
    Call ERROR_EVENT("MkChar")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function PadL(pstr As String, pcnt As Long, ch As String)
Dim strTmp As String
    On Error GoTo doError
    strTmp = pstr
    Do While VBA.Len(strTmp) < pcnt
        strTmp = ch + strTmp
    Loop
    PadL = strTmp
Exit Function
doError:
    Call ERROR_EVENT("PadL")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function MkVal(P_Str As String) As Long
Dim Tran As String
Dim ret, i As Long
Dim ch As String
    
    On Error GoTo doError
    Tran = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    ret = 0
    i = 1
    Do While i <= VBA.Len(P_Str)
        ch = Mid$(P_Str, i, 1)
        ret = ret + (VBA.InStr(Tran, ch) - 1) * (36 ^ (Len(P_Str) - i))
        i = i + 1
    Loop
    MkVal = ret
Exit Function
doError:
    Call ERROR_EVENT("MkVal")
End Function
' -------------------------------------------------------------------------------------------------------
' Проверка на пустоту строки
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function EmptyStr(pstr As String) As Boolean
 EmptyStr = (Len(Trim$(pstr)) = 0)
End Function
' -------------------------------------------------------------------------------------------------------
' Функция добавления "\"
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function AddSlash(pstr As String) As String
 AddSlash = IIf(Right$(pstr, 1) = "\", pstr, pstr + "\")
End Function
' -------------------------------------------------------------------------------------------------------
' Функция удаления "\"
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function DelSlash(pstr As String) As String
 DelSlash = IIf(Right$(pstr, 1) = "\", VBA.Left(pstr, VBA.Len(pstr) - 1), pstr)
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function GetNumLen(pNumLen As Long, Optional charW As Long = 1) As Long
 GetNumLen = Int((pNumLen * 8) / 3.5 + 0.5) * charW + 2 * charW
End Function
' -------------------------------------------------------------------------------------------------------
' Функция удаления адреса ячейки (номера строки в Excel) в формулах
' StrFormula - строка формулы (полностью)
' StrOldCell - Формат ячейки для удаления - "$" + адресс ячейки + " " ; ex:("$123 ")
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function DELETE_ADDRESS_CELL(StrFormula As String, StrOldCell As String, typeF As Long) As String
Dim StrMain As String, StrLeftPart As String, StrRightPart As String, StrReturn As String
Dim StrF As String
Dim AllLen As Long, Cnt As Integer, Position As Integer, _
CellLenght As Integer, OstLen As Integer, Occu As Integer
    
On Error GoTo doError
    

If typeF = 1 Then ' Функция
    Position = VBA.InStr(1, StrFormula, "(", vbTextCompare)
    StrReturn = VBA.Right(StrFormula, VBA.Len(StrFormula) - Position)
    StrF = VBA.Left(StrFormula, Position)
Else
    StrReturn = StrFormula
End If
CellLenght = VBA.Len(StrOldCell)
AllLen = VBA.Len(StrReturn)
Occu = Occur(StrReturn, StrOldCell) ' кол - во вхождений

For Cnt = 1 To Occu
        StrMain = StrReturn
        AllLen = VBA.Len(StrMain)
        Position = VBA.InStr(1, StrMain, StrOldCell, vbTextCompare) ' определим позицию вхождения
        If Position = 1 Then ' first Item
            If AllLen <> CellLenght Then
                StrReturn = VBA.Right(StrMain, AllLen - Position - CellLenght)  'правая часть после вхождения
            Else
                StrReturn = ""
                Exit For
            End If
        Else
            If Position = AllLen - CellLenght + 1 Then ' Last Item
                StrReturn = VBA.Left(StrMain, Position - 2)  'левая часть до вхождения
            Else ' Middle Item
                StrLeftPart = VBA.Left(StrMain, Position - 2) 'левая часть до вхождения
                StrRightPart = VBA.Right(StrMain, AllLen - Position - CellLenght + 1) 'правая часть после вхождения
                StrReturn = StrLeftPart + StrRightPart ' результирующая строка
            End If
        End If
Next
'Проанализируем выражение на предмет наличия ячеек
If typeF = 1 Then
    DELETE_ADDRESS_CELL = IIf(StrReturn = "", "", StrF) + StrReturn
Else
    DELETE_ADDRESS_CELL = StrReturn
End If

Exit Function
doError:
    Call ERROR_EVENT("DELETE_ADDRESS_CELL")
End Function
' -------------------------------------------------------------------------------------------------------
' Декодирование PSW
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function decode_psw(ByVal str As String) As String
Dim p As String, char As Byte, i As Integer
    str = VBA.Mid(str, 3, Len(str) - 2)
    p = ""
    For i = 1 To Len(str)
        char = Asc(VBA.Mid(str, i, 1))
        p = p + VBA.Chr((char + 7) Xor 7)
    Next
    decode_psw = p
End Function
' -------------------------------------------------------------------------------------------------------
' возвращает код из строки target
' sep - необязательный параметр - разделитель составного кода
' pageName - необязательный параметр - имя листа
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function getCode(ByVal target As Long, Optional sep As String = "", Optional pageName As String = "") As String
    Dim lSheetsService, lSheetsReport, temp, i, pnAddress_Col
    Dim oldSheet
On Error GoTo 0 'doError
    
    Set lSheetsService = Sheets("Service")
    Set oldSheet = Sheets(Sheets("Service").Range("B19").Text)
    Set lSheetsReport = Sheets(IIf(pageName = "", Sheets("Service").Range("B19").Text, pageName))
    temp = ""
    If pageName <> "" Then lSheetsReport.Activate
    pnAddress_Col = Sheets("Service").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 lSheetsService.Range("B22") - 1 ' было lSheetsService.Range("E4") - 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:
    getCode = temp
    If pageName <> "" Then oldSheet.Activate
Exit Function
doError:
    Call ERROR_EVENT("getCode")
End Function
' -------------------------------------------------------------------------------------------------------
' возвращает полный код из строки target (включая коды типа 0000)
' sep - необязательный параметр - разделитель составного кода
' pageName - необязательный параметр - имя листа
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function getFullCode(ByVal target As Long, Optional sep As String = "", Optional pageName As String = "") As String
    Dim lSheetsService, lSheetsReport, temp, i, pnAddress_Col
    
On Error GoTo doError
    
    Set lSheetsService = Sheets("Service")
    Set lSheetsReport = Sheets(IIf(pageName = "", Sheets("Service").Range("B19").Text, pageName))
    temp = ""
    pnAddress_Col = Sheets("Service").Range("C6")
    If lSheetsService.Range("B22").Value = 1 Then
       temp = lSheetsReport.Cells(target, pnAddress_Col - lSheetsService.Range(lSheetsService.Range("E1")))
    Else
       temp = ""
       For i = 0 To VBA.Len(lSheetsService.Range("B21")) - 1 'lSheetsService.Range("E4") - 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:
    getFullCode = temp

Exit Function
doError:
    Call ERROR_EVENT("getFullCode")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub DEL_STR()
Dim lnLinkBar As Long, lnRow As Long
Dim lSheetsReport As Object, lSheetsService As Object, lnRes As Long, flag As Boolean, i As Integer
Set lSheetsReport = Sheets(Sheets("Service").Range("B19").Text)
Set lSheetsService = Sheets("Service")
   
On Error GoTo doError
    If Sheets("Service").Range("B72") <> "" Then
        ActiveSheet.Rows(ActiveCell.row).Delete
        Exit Sub
    End If
    
' начало заполнения листа отчета - с какой записи
pnAddress_Row = Sheets("Service").Range("C5")
' - с какой колонки
pnAddress_Col = Sheets("Service").Range("C6")

' если ячейка попадает в ранг
If lSheetsReport.Cells(ActiveCell.row, 1) <> "" Then
    If lSheetsReport.Cells(ActiveCell.row, 1).Value <> 0 Then
        If (lSheetsService.Range("A9") - lSheetsService.Range("C5") > 1) And (lSheetsReport.Cells(ActiveCell.row, 1) <> 1) Then
            With lSheetsReport
                'снять защиту
                .Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
                lnRow = ActiveCell.row
                lnLinkBar = .Cells(lnRow, pnAddress_Col - lSheetsService.Range("E2"))
                flag = False
                For i = 1 To lSheetsService.Range("A10").Value
                    If VBA.Trim(.Cells(lnRow, 2 + i).Text) <> "" Then flag = True
                Next
                .Cells(lnRow, 1).EntireRow.Delete
                lSheetsService.Range("A9").Value = lSheetsService.Range("A9").Value - 1
                ' Установить защиту
                .Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
                If flag Then Call INSERT_LINK_IN_COLLECTION("DEL", lnLinkBar, lSheetsService.Range("B20").Value)
                If lSheetsService.Range("B39") = 1 Then
                  Call Application.Run("After_Del_Str", lnRow)
                End If
            End With
        Else
            Call MsgBox("Нельзя удалить последнюю строку бланка!", vbOKOnly)
        End If
    End If
End If

Exit Sub
doError:
    Call ERROR_EVENT("DEL_STR")
End Sub
' -------------------------------------------------------------------------------------------------------
' Определяет подстроку в строке по разделителю
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function getNextSubstr(str As String, border As String) As String
Dim lnFirst As Integer
   
    On Error GoTo doError
    lnFirst = VBA.InStr(1, str, border, vbTextCompare)
    If lnFirst = 0 Then ' нет разделителя
        getNextSubstr = VBA.Trim(str)
        str = ""
    Else
        getNextSubstr = VBA.Trim(VBA.Left(str, lnFirst - 1))
        str = VBA.Right(str, VBA.Len(str) - lnFirst + 1 - VBA.Len(border))
    End If
Exit Function
doError:
    Call ERROR_EVENT("getNextSubstr")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub Add_Str()
Dim lnRowAllCount As Long, lnColumnAllCount As Long
Dim lSheetsService As Object, lSheetsReport As Object
Dim lcprivName As String, lcprivCode As String, lnprivRazdel As String, saveRow As Integer

    On Error GoTo doError
    If Sheets("Service").Range("B72") <> "" Then
        ActiveSheet.Rows(ActiveCell.row).Insert
        Exit Sub
    End If
    Set lSheetsService = Sheets("Service")
    Set lSheetsReport = Sheets(Sheets("Service").Range("B19").Text)
    'снять защиту
    lSheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    ' начало заполнения листа отчета - с какой записи
    pnAddress_Row = Sheets("Service").Range("C5")
    ' - с какой колонки
    pnAddress_Col = Sheets("Service").Range("C6")
    lnRowAllCount = lSheetsService.Range("A9")
    lnColumnAllCount = lSheetsService.Range("A10")
    ' если ячейка попадает в строковый ранг
    If lSheetsReport.Cells(ActiveCell.row, 1) <> "" Then
        If lSheetsReport.Cells(ActiveCell.row, 1).Value <> 0 Then
          'снять защиту
          lSheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
          'вставляем строку
          saveRow = ActiveCell.row
          If lSheetsReport.Cells(ActiveCell.row, 1).Value = 1 Then
            lSheetsReport.Cells(ActiveCell.row - 1, 1).EntireRow.Insert
            lSheetsReport.Cells(ActiveCell.row - 1, 1).RowHeight = 0
            lSheetsReport.Cells(ActiveCell.row - 1, 1).RowHeight = lSheetsReport.Cells(ActiveCell.row + 1, 1).RowHeight
            lSheetsReport.Cells(ActiveCell.row - 1, 3).Select
          Else
            lSheetsReport.Cells(ActiveCell.row, 1).EntireRow.Insert
            lSheetsReport.Cells(ActiveCell.row, 1).RowHeight = 0
            lSheetsReport.Cells(ActiveCell.row, 1).RowHeight = lSheetsReport.Cells(ActiveCell.row + 1, 1).RowHeight
          End If
          lSheetsService.Range("A9").Value = lSheetsService.Range("A9").Value + 1
          ' пропишем атрибуты строки
          lSheetsReport.Cells(ActiveCell.row, pnAddress_Col - lSheetsService.Range("E2")).Value = lSheetsReport.Range("A1").Value + 1
          'снять защиту
          lSheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
          lSheetsReport.Cells(ActiveCell.row, 2) = lSheetsService.Range("B20").Value
          'поставить защиту
          lSheetsReport.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False
          
          If lSheetsService.Range("B39") = 1 Then
            Call Application.Run("After_Add_Str", saveRow)
          End If
        End If
   End If

Exit Sub
doError:
    Call ERROR_EVENT("Add_Str")
End Sub
' -------------------------------------------------------------------------------------------------------
' Инициализация переменных
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub init_data()

With Sheets("Service")
    'Иницилизация данных
    cSrv = VBA.Trim(.Range("A3").Value)
    cDb = VBA.Trim(.Range("A4").Value)
    cUser = VBA.Trim(.Range("A5").Value)
    cPwd = decode_psw(VBA.Trim(.Range("A6").Value))
    nNtUser = VBA.Val(VBA.Trim(.Range("A22").Value))

    KRIT_SHABLON_COND_COLUMNCOUNT = .Range("KRIT_SHABLON_COND").Columns.count
    KRIT_SHABLON_COND_COLUMN = .Range("KRIT_SHABLON_COND").column
    KRIT_SHABLON_COND_ROW = .Range("KRIT_SHABLON_COND").row

    KRIT_SPR_COLUMNCOUNT = .Range("KRIT_SPR").Columns.count
    KRIT_SPR_COLUMN = .Range("KRIT_SPR").column
    KRIT_SPR_ROW = .Range("KRIT_SPR").row
    
    KRIT_GRAF_COLUMNCOUNT = .Range("KRIT_GRAF").Columns.count
    KRIT_GRAF_COLUMN = .Range("KRIT_GRAF").column
    KRIT_GRAF_ROW = .Range("KRIT_GRAF").row

    KRIT_RAZDEL_COLUMNCOUNT = .Range("KRIT_RAZDEL").Columns.count
    KRIT_RAZDEL_COLUMN = .Range("KRIT_RAZDEL").column
    KRIT_RAZDEL_ROW = .Range("KRIT_RAZDEL").row

    KRIT_ZNAK_COLUMNCOUNT = .Range("KRIT_ZNAK").Columns.count
    KRIT_ZNAK_COLUMN = .Range("KRIT_ZNAK").column
    KRIT_ZNAK_ROW = .Range("KRIT_ZNAK").row

    KRIT_TYPE_FORMULA_COLUMNCOUNT = .Range("KRIT_TYPE_FORMULA").Columns.count
    KRIT_TYPE_FORMULA_COLUMN = .Range("KRIT_TYPE_FORMULA").column
    KRIT_TYPE_FORMULA_ROW = .Range("KRIT_TYPE_FORMULA").row

End With

With Sheets("ALG")
    KRIT_ALG_COLUMNCOUNT = .Range("KRIT_ALG").Columns.count
    KRIT_ALG_COLUMN = .Range("KRIT_ALG").column
    KRIT_ALG_ROW = .Range("KRIT_ALG").row
End With

With Sheets("FORM")
    KRIT_FORM_COLUMNCOUNT = .Range("KRIT_FORM").Columns.count
    KRIT_FORM_COLUMN = .Range("KRIT_FORM").column
    KRIT_FORM_ROW = .Range("KRIT_FORM").row
End With
      
With Sheets("SQLDATA1")
    KRIT_SQLDATA1_COLUMNCOUNT = .Range("KRIT_SQLDATA1").Columns.count
    KRIT_SQLDATA1_COLUMN = .Range("KRIT_SQLDATA1").column
    KRIT_SQLDATA1_ROW = .Range("KRIT_SQLDATA1").row
End With
      
With Sheets("OTBOR_COND")
    KRIT_STR_COND_COLUMNCOUNT = .Range("KRIT_STR_COND").Columns.count
    KRIT_STR_COND_COLUMN = .Range("KRIT_STR_COND").column
    KRIT_STR_COND_ROW = .Range("KRIT_STR_COND").row
End With

End Sub
' -------------------------------------------------------------------------------------------------------
' Обработчик ошибок
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub ERROR_EVENT(str As String)
    MsgBox "Ошибка " + VBA.str(ERR.Number) + ". " + ERR.Description + ", функция " + str, vbCritical, "Ошибка в программе"
    Application.ScreenUpdating = True
End Sub
' -------------------------------------------------------------------------------------------------------
' Калькулятор
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub show_calc()
On Error GoTo doError
    Shell ("calc.exe")
Exit Sub
doError:
    Call ERROR_EVENT("show_calc")
End Sub
' -------------------------------------------------------------------------------------------------------
' mode = 1 -  WIN -> DOS, mode <>1 -  DOS -> WIN
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function convert_dos_win(str As String, mode As Integer) As String
Dim OutputStr As String, code As Integer

On Error GoTo doError
    OutputStr = VBA.Space(VBA.Len(str))
    If mode = 1 Then
        code = CharToOem(str, OutputStr)
    Else
        code = OemToChar(str, OutputStr)
    End If
    convert_dos_win = OutputStr
If code = 1 Then Exit Function
doError:
    Call ERROR_EVENT("WRITE_TO_FILE")
End Function
' -------------------------------------------------------------------------------------------------------
' Возвращает формулу контроля
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function getFormula(num As Integer, linkBar As Long, linkGraf As Integer, Optional shortFormat As Boolean = False, Optional byCode As Boolean = False) As String
Dim lnStartAddress, lnStartEmpty, lcPart, lnNumRow, lcLetter, lcFormTextWork, lcZnak
Dim lnOccur As Integer, nCnt As Integer, str As String, typeF As Integer
Dim lcFormText As String, tGraf As String, tBar As String
Dim sumFlag As Boolean, pageName As String
Dim lnNumRow1 As Integer, linkItog As Integer, codeItog As String

'Stop
On Error GoTo doError
With Sheets("Form")
    .Range(.Cells(KRIT_FORM_ROW + 1, KRIT_FORM_COLUMN), .Cells(KRIT_FORM_ROW + 1, KRIT_FORM_COLUMN + KRIT_FORM_COLUMNCOUNT - 2)) = ""
End With
With Sheets("Form")
    .Cells(KRIT_FORM_ROW + 1, KRIT_FORM_COLUMN + 2) = num
    .Cells(KRIT_FORM_ROW + 2, KRIT_FORM_COLUMN).CALCULATE 'text
    .Cells(KRIT_FORM_ROW + 3, KRIT_FORM_COLUMN).CALCULATE 'text
    .Cells(KRIT_FORM_ROW + 6, KRIT_FORM_COLUMN).CALCULATE 'link_graf
    .Cells(KRIT_FORM_ROW + 7, KRIT_FORM_COLUMN).CALCULATE 'link_bar
    lcFormText = .Cells(KRIT_FORM_ROW + 2, KRIT_FORM_COLUMN)
    typeF = IIf(.Cells(KRIT_FORM_ROW + 7, KRIT_FORM_COLUMN) = -1, 4, IIf(.Cells(KRIT_FORM_ROW + 6, KRIT_FORM_COLUMN) = 0, 1, 2))
    linkItog = .Cells(KRIT_FORM_ROW + 3, KRIT_FORM_COLUMN)
End With

With Sheets("Service")
    .Cells(.Range("KRIT_ZNAK").row + 1, .Range("KRIT_ZNAK").column) = linkItog
    .Cells(.Range("KRIT_ZNAK").row + 1, .Range("KRIT_ZNAK").column + 1) = ""
    .Cells(.Range("KRIT_ZNAK").row + 2, .Range("KRIT_ZNAK").column).CALCULATE
    codeItog = .Cells(.Range("KRIT_ZNAK").row + 2, .Range("KRIT_ZNAK").column)
    .Cells(.Range("KRIT_ZNAK").row + 1, .Range("KRIT_ZNAK").column) = ""
End With

lcFormTextWork = lcFormText
' Определим колличество вхождений - Количество участников (строк или граф)
lnOccur = Occur(lcFormText, "$") - Occur(lcFormText, ":")
str = ""

With Sheets("Service")
    .Range(.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN), .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + KRIT_GRAF_COLUMNCOUNT - 2)) = ""
End With

If linkBar > 0 Then tBar = getCode(linkBar) Else: tBar = """Все строки"""
With Sheets("Service")
    .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN) = linkGraf
    .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 2) = .Range("B20")
    .Cells(KRIT_GRAF_ROW + 2, KRIT_GRAF_COLUMN).CALCULATE
    tGraf = """" + .Cells(KRIT_GRAF_ROW + 2, KRIT_GRAF_COLUMN) + """"
    .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN) = ""
End With
If Not shortFormat Then
    If typeF < 4 Then
        str = "  строка " + tBar + ",  графа " + tGraf + vbNewLine + "  формула: " + tBar + " " + codeItog + " "
    Else
        str = "  строка " + tBar + ",  графа " + tGraf + vbNewLine + "  формула: " + tGraf + " " + codeItog + " "
    End If
Else
    If typeF < 4 Then
        str = tBar + " " + codeItog + " "
    Else
        str = tGraf + " " + codeItog + " "
    End If
End If
For nCnt = 1 To lnOccur
    If typeF < 4 Then
        lnStartAddress = VBA.InStr(1, lcFormTextWork, "$", vbTextCompare)
        lnStartEmpty = VBA.InStr(lnStartAddress, lcFormTextWork, " ", vbTextCompare)
        lcPart = VBA.Mid(lcFormTextWork, 2, lnStartEmpty - 1)
        If VBA.InStr(lcPart, "!") <> 0 Then
            pageName = VBA.Mid(lcPart, 3, VBA.InStr(lcPart, "!") - 3)
        Else
            pageName = ""
        End If
        lcZnak = VBA.Left(lcPart, 1)
        lnNumRow = VBA.Val(VBA.Right(lcPart, VBA.Len(lcPart) - VBA.InStr(1, lcPart, "$", vbTextCompare)))
        lcLetter = VBA.Mid(lcPart, 2, VBA.InStr(1, lcPart, "$", vbTextCompare) - 2)
        sumFlag = IIf(VBA.InStr(lcPart, ":") <> 0, True, False)
        lcFormTextWork = VBA.Right(lcFormTextWork, VBA.Len(lcFormTextWork) - VBA.Len(lcPart))
        If Not sumFlag Then
            str = str + lcZnak + IIf(pageName <> "", pageName + "!", "") + getCode(lnNumRow, "", pageName)
        Else
            lcZnak = lcZnak + " СУММ"
            lnNumRow = VBA.Val(VBA.Mid(lcPart, VBA.InStr(VBA.InStr(lcPart, ":"), lcPart, "$") + 1, VBA.InStr(lcPart, ")") - VBA.InStr(VBA.InStr(lcPart, ":"), lcPart, "$") - 1))
            lnNumRow1 = VBA.Val(VBA.Mid(lcPart, VBA.InStr(lcPart, "$") + 1, VBA.InStr(lcPart, ":") - VBA.InStr(lcPart, "$") - 1))
            
            str = str + lcZnak + "(" + getCode(lnNumRow1) + ":" + getCode(lnNumRow) + ")"
        End If
    Else
        lnStartAddress = VBA.InStr(1, lcFormTextWork, "$", vbTextCompare)
        lnStartEmpty = VBA.InStr(lnStartAddress, lcFormTextWork, " ", vbTextCompare)
        lcPart = VBA.Mid(lcFormTextWork, 2, lnStartEmpty - 1)
        lcZnak = VBA.Left(lcPart, 1)
        lnNumRow = VBA.Val(VBA.Right(lcPart, VBA.Len(lcPart) - VBA.InStr(1, lcPart, "$", vbTextCompare)))
        lcLetter = VBA.Mid(lcPart, 4, 1) + IIf(VBA.Mid(lcPart, 5, 1) >= "A" And VBA.Mid(lcPart, 5, 1) <= "Z", VBA.Mid(lcPart, 5, 1), "")
        With Sheets("Service")
            .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 1) = lcLetter
            .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN) = ""
            .Cells(KRIT_GRAF_ROW + 2, KRIT_GRAF_COLUMN).CALCULATE
            str = str + " " + lcZnak + " " + """" + .Cells(KRIT_GRAF_ROW + 2, KRIT_GRAF_COLUMN) + """"
        End With
        lcFormTextWork = VBA.Right(lcFormTextWork, VBA.Len(lcFormTextWork) - VBA.Len(lcPart))
    End If
Next
With Sheets("Service")
    .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 1) = ""
End With
With Sheets("Form")
    .Cells(KRIT_FORM_ROW + 1, KRIT_FORM_COLUMN + 2) = ""
End With
getFormula = str
Exit Function
doError:
    Call ERROR_EVENT("getFormula")
End Function
' -------------------------------------------------------------------------------------------------------
' Возвращает формулу горизонтального контроля
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function getFormulaH(lcFormText As String) As String
Dim lnStartAddress, lnStartEmpty, lcPart, lnNumRow, lcLetter, lcFormTextWork, lcZnak
Dim lnOccur As Integer, nCnt As Integer, str As String

lcFormTextWork = lcFormText
' Определим колличество вхождений - Количество участников (строк или граф)
lnOccur = Occur(lcFormText, "$")
str = ""
For nCnt = 1 To lnOccur
Next
getFormulaH = str
With Sheets("Service")
    .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + 1) = ""
End With
With Sheets("Form")
    .Cells(KRIT_FORM_ROW + 1, KRIT_FORM_COLUMN + 2) = ""
End With

Exit Function
doError:
    Call ERROR_EVENT("getFormulaH")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub restore_default()
Dim i As Integer
    For i = 1 To Application.CommandBars.count
        Application.CommandBars(i).Enabled = True
    Next
End Sub
' -------------------------------------------------------------------------------------------------------
' Функция возвращает True если имя существует
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function exists_name(s As String) As Boolean
Dim i As Integer
    For i = 1 To Application.Names.count
        If Application.Names(i).name = s Then
            exists_name = True
            Exit Function
        End If
    Next
    exists_name = False
End Function
' -------------------------------------------------------------------------------------------------------
' Фукция преобразует число в строку для вывода в файл
' size - размер поля
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function num_To_Str(n As Double, size As Integer) As String
Dim str As String
On Error GoTo doError
'size=0
    If n <> 0 Then
         str = Replace_in_Str(Format(VBA.Val(VBA.str(n)), "0.00"), ",", ".")
         If size - VBA.Len(str) > 0 Then num_To_Str = Space(size - VBA.Len(str)) + str Else num_To_Str = str
    Else
         If Sheets("Service").Range("B66") <> 1 Then
              If size - 4 > 0 Then num_To_Str = Space(size - 4) + "0.00" Else num_To_Str = "0.00"
         Else
              num_To_Str = Space(size)
         End If
    End If
Exit Function
doError:
    Call ERROR_EVENT("num_To_Str. Возможно, размер числа очень большой.")
End Function
' -------------------------------------------------------------------------------------------------------
' Определение PageHeight
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub SetPageHeight()
Dim nZoom As Single, DX As Single, nPages As Integer
    If ActiveSheet.PageSetup.Zoom = False Then
        nPages = ActiveSheet.PageSetup.FitToPagesWide - 1
        ActiveSheet.PageSetup.Zoom = 100
        ActiveSheet.PageSetup.PrintTitleColumns = ""
        If ActiveSheet.VPageBreaks.count > nPages Then
            nZoom = 100
            DX = 100
            With ActiveSheet.PageSetup
                While (DX > 0.5) And (nZoom > 10)
                    DX = DX / 2
                    If ActiveSheet.VPageBreaks.count > nPages Then
                        nZoom = nZoom - DX
                    Else
                        nZoom = nZoom + DX
                    End If
                    .Zoom = Int(nZoom)
                    .PrintTitleColumns = ""
                Wend
                If ActiveSheet.VPageBreaks.count > nPages Then
                    .Zoom = .Zoom - 1
                    .PrintTitleColumns = ""
                End If
            End With
        End If
    End If
End Sub
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub SetLastRowsCount(nLastRowsCount As Integer)
Dim nLastRow As Integer, nPageRow As Integer
    If nLastRowsCount > 0 Then
        nLastRow = LastCell(ActiveSheet.Cells).row + 1
        ActiveWindow.ScrollRow = nLastRow
        If ActiveSheet.HPageBreaks.count > 0 Then
            nPageRow = ActiveSheet.HPageBreaks(ActiveSheet.HPageBreaks.count).Location.row
            If (nLastRow - nPageRow) < nLastRowsCount Then
                ActiveSheet.HPageBreaks.Add ActiveSheet.Cells(nLastRow - nLastRowsCount, 1)
            End If
        End If
        ActiveWindow.ScrollRow = 1
    End If
End Sub
' -------------------------------------------------------------------------------------------------------
' Последняя ячейка
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function LastCell(r As Excel.Range) As Range
Dim rLast As Excel.Range
    Set rLast = r.Cells.SpecialCells(xlLastCell)
    On Error Resume Next
    If rLast.Value = "" Then
        Set LastCell = r.Parent.Cells(r.Parent.Cells.Find("*", rLast, , , xlByRows, xlPrevious).row, r.Parent.Cells.Find("*", rLast, , , xlByColumns, xlPrevious).column)
        If ERR.Number <> 0 Then Set LastCell = r.Parent.Cells(1, 1)
    Else
        Set LastCell = rLast
    End If
    On Error GoTo 0
End Function
' -------------------------------------------------------------------------------------------------------
' Автоподбор ширины строк
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub AutoFitRow(rRange As Range, rwRange As Range)
Dim nWidth As Integer, nHeight As Integer, F As Font
    rRange.Select
    Set rRange = Selection
    nWidth = rRange.Columns.Width
    nHeight = rRange.Rows.RowHeight
    rwRange.ColumnWidth = nWidth * rRange.Cells(1, 1).ColumnWidth / rRange.Cells(1, 1).Columns.Width
    rwRange.Value = rRange.Value
    rwRange.WrapText = True
    Set F = rRange.Cells(1, 1).Font
    With rwRange.Font
        .name = F.name
        .FontStyle = F.FontStyle
        .size = F.size
        .Bold = F.Bold
        .Italic = F.Italic
    End With
    rwRange.Rows.AutoFit
    nHeight = IIf(rwRange.Rows.RowHeight > nHeight, rwRange.Rows.RowHeight, nHeight)
    rRange.Rows.RowHeight = nHeight
End Sub
' -------------------------------------------------------------------------------------------------------
' Hot Key "A"
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Sub admin()
Dim lcPath As String
    Call restore_default
    Set ToolbarAction = CommandBars("Редактор")
    With ToolbarAction.Controls.Add(Type:=msoControlButton): .FaceId = 346: .Style = msoButtonIcon
        .Caption = "Глобальное обновление бланка"
        .OnAction = "BlankUpdate"
    End With
    With ToolbarAction.Controls.Add(Type:=msoControlButton): .FaceId = 346: .Style = msoButtonIcon
        .Caption = "Импорт формул из файла"
        .OnAction = "importForm"
    End With
    Application.DisplayFormulaBar = True
    With ThisWorkbook.VBProject.VBComponents
        lcPath = ThisWorkbook.Sheets("Start").Range("A3")
        .Import (lcPath + "admin_tools.bas")
        .Import (lcPath + "auto_form.bas")
        .Import (lcPath + "auto_alg.frm")
    End With
    Application.OnKey "+^%{a}", ""
    Application.ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Application.ActiveWindow.DisplayHeadings = True
End Sub
' -------------------------------------------------------------------------------------------------------
' Возвращает Link строки
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function getLineNum(nLink As Long) As Long
Dim LookRange
    Set LookRange = Sheets(Sheets("Service").Range("B19").Text).Range("LINK").Find(nLink, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not LookRange Is Nothing Then
        getLineNum = LookRange.row
    Else
        getLineNum = 0
    End If
End Function
' -------------------------------------------------------------------------------------------------------
' Возвращает Link строки mode=0 - link, mode= 1 - номер строки
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Function getLink(code As String, Optional sheetName As String = "", Optional Razdel As Integer = 0, Optional mode As Integer = 0, Optional book As Workbook = Nothing) As Long
Dim LookRange As Range, sheetsReport As Object, oldSheet
    If sheetName = "" Then
        sheetName = Sheets("Service").Range("B19").Text
    End If
    If book Is Nothing Then
        Set book = Application.ThisWorkbook
    End If
    Set sheetsReport = book.Sheets(sheetName)
    Set oldSheet = book.ActiveSheet
    sheetsReport.Select
    ' защита листа - снять
    sheetsReport.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
    Set LookRange = sheetsReport.Range("CODE_STR").Find(code, LookIn:=xlFormulas, lookat:=xlWhole)
nnn:
    If Not LookRange Is Nothing Then
        ' пропишем ячейку в отчет (посмотреть настройку на Ед.Изм)
        If (Razdel = sheetsReport.Cells(LookRange.row, 2)) Or (Razdel = 0) Then
            If mode = 0 Then
                getLink = sheetsReport.Cells(LookRange.row, 1)
            Else
                getLink = LookRange.row
            End If
        Else
            Set LookRange = sheetsReport.Range("CODE_STR").FindNext(LookRange)
            GoTo nnn
        End If
    Else
        getLink = 0
    End If
    oldSheet.Select
End Function
' -------------------------------------------------------------------------------------------------------
' Вывод алгортимов отбора в файл
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub print_cond()
Dim i As Integer
Dim sheetsService, sheetsReport, SheetsCond, sheetsAlg As Worksheet
Dim filename, str As String
Dim lnColumn1, lnRow1, row11, col11, cond_row, cond_col, alg_row, alg_col As Long
Dim column, Graf, gr, j As Integer

    filename = GetFileFromAPI("c:\")
    If filename = "" Then
        Exit Sub
    End If
    Open filename For Output As #1
    Print #1, Sheets("Service").Range("A15").Text
    Set sheetsService = Sheets("Service")
    Set sheetsAlg = Sheets("ALG")
    Set SheetsCond = Sheets("OTBOR_COND")

    With sheetsService.Range("KRIT_RAZDEL")
        lnColumn1 = .column
        lnRow1 = .row
    End With
    row11 = sheetsService.Range("KRIT_GRAF").row
    col11 = sheetsService.Range("KRIT_GRAF").column
    alg_row = sheetsAlg.Range("KRIT_ALG").row
    alg_col = sheetsAlg.Range("KRIT_ALG").column
    cond_row = SheetsCond.Range("KRIT_STR_cond").row
    cond_col = SheetsCond.Range("KRIT_STR_cond").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
    
    sheetsReport.Activate
    For Graf = 1 To sheetsService.Range("A10")
        Print #1, "Раздел " + Trim(VBA.str(i)) + ", графа " + VBA.Trim(VBA.str(Graf))
        For j = sheetsService.Range("C5") To sheetsService.Range("A9")
            If sheetsReport.Cells(j, 1) <> 0 Then
                sheetsAlg.Cells(alg_row + 1, alg_col) = sheetsReport.Cells(j, 1)
                sheetsAlg.Cells(alg_row + 1, alg_col + 1) = Graf
                gr = Graf
qqq:
                If sheetsAlg.Cells(alg_row + 2, alg_col + 1) = 0 And sheetsAlg.Cells(alg_row + 2, alg_col + 2) = 0 Then 'алг. есть
                    If sheetsAlg.Cells(alg_row + 2, alg_col) = 0 Then 'алг. по формуле
                
                    Else
                        str = getCode(j) + Space(35 - Len(getCode(j)))
                        SheetsCond.Cells(cond_row + 1, cond_col) = sheetsReport.Cells(j, 1)
                        SheetsCond.Cells(cond_row + 1, cond_col + 1) = gr
                        If SheetsCond.Cells(cond_row + 2, cond_col + 1) <> 1 Then            'EdiS - ошибка если функция Len вернула значение >250
                            str = str + "   |   " + SheetsCond.Cells(cond_row + 8, cond_col) '+ Space(250 - Len(SheetsCond.Cells(cond_row + 8, cond_col)))
                            If SheetsCond.Cells(cond_row + 9, cond_col + 1) = 0 Then str = str + "   |   " + SheetsCond.Cells(cond_row + 9, cond_col) + Space(IIf(Len(SheetsCond.Cells(cond_row + 9, cond_col)) < 30, 30 - Len(SheetsCond.Cells(cond_row + 9, cond_col)), 0))
                            Print #1, str
                        End If
                    End If
                Else
                    If gr <> 0 Then
                        sheetsAlg.Cells(alg_row + 1, alg_col + 1) = 0
                        gr = 0
                        GoTo qqq
                    End If
                End If
            End If
        Next
    Next
Next

Close #1

Call MsgBox("Файл " + filename + " успешно создан", vbInformation, "Внимание!")

End Sub
' -------------------------------------------------------------------------------------------------------
' Вывод Формул в файл
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Public Sub print_form()
Dim i As Integer, sheetsService As Worksheet, sheetsReport As Worksheet, SheetsFORM, sheetsAlg
Dim filename As String
Dim lnColumn1, lnRow1, row11, col11, j, cond_row, cond_col, alg_row, alg_col, str As String
Dim column As Integer, Graf As Integer
Dim typeF As Integer

filename = GetFileFromAPI("c:\")
If filename = "" Then
    Exit Sub
End If
Open filename For Output As #1
Print #1, Sheets("Service").Range("A15").Text
Set sheetsService = Sheets("Service")
Set sheetsAlg = Sheets("ALG")
Set SheetsFORM = Sheets("FORM")

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

Application.ScreenUpdating = False
row11 = sheetsService.Range("KRIT_GRAF").row
col11 = sheetsService.Range("KRIT_GRAF").column
alg_row = sheetsAlg.Range("KRIT_ALG").row
alg_col = sheetsAlg.Range("KRIT_ALG").column
Call init_data

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
    
    sheetsReport.Activate
    For typeF = 1 To 4
        Select Case typeF
            Case 1
                Print #1, "Раздел " + Trim(VBA.str(i)) + ", формулы контроля строки "
            Case 2
                Print #1, "Раздел " + Trim(VBA.str(i)) + ", формулы контроля ячейки "
            Case 4
                Print #1, "Раздел " + Trim(VBA.str(i)) + ", формулы контроля графы "
        End Select
        
        j = 2
        While VBA.Trim(SheetsFORM.Cells(j, 1).Text) <> ""
            If SheetsFORM.Cells(j, 8) = i And SheetsFORM.Cells(j, 7) = typeF Then
                If typeF <> 4 Then
                    Print #1, "   " + getFormula(SheetsFORM.Cells(j, 3), getLineNum(SheetsFORM.Cells(j, 1)), SheetsFORM.Cells(j, 2), True, False)
                Else
                    Print #1, "   " + getFormula(SheetsFORM.Cells(j, 3), SheetsFORM.Cells(j, 1), SheetsFORM.Cells(j, 2))
                End If
            End If
            j = j + 1
        Wend
    Next
Next

Close #1

Application.ScreenUpdating = True

Call MsgBox("Файл " + filename + " успешно создан", vbInformation, "Внимание!")

End Sub
' -------------------------------------------------------------------------------------------------------
' Возвращает формулу контроля mode: + 1 - показывать суммы
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function getCellCode(lcFormText As String, Optional mode As Integer = 1) As String
Dim lnStartAddress, lnStartEmpty, lcPart, lnNumRow, lcLetter, lcFormTextWork As String, lcZnak
Dim lnOccur As Integer, nCnt As Integer, str As String, typeF As Integer
Dim tGraf As String, tBar As String
Dim sumFlag As Boolean, pageName As String
Dim lnNumRow1 As Integer, linkItog As Integer, codeItog As String
Dim shortFormat As Boolean
Dim lNumber As Double
'Stop
On Error GoTo doError

lcFormTextWork = VBA.Trim(lcFormText)
' Определим колличество вхождений - Количество участников (строк или граф)
lnOccur = 1
str = ""

With Sheets("Service")
    .Range(.Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN), .Cells(KRIT_GRAF_ROW + 1, KRIT_GRAF_COLUMN + KRIT_GRAF_COLUMNCOUNT - 2)) = ""
End With

While lcFormTextWork <> ""
        lcZnak = getNextSubstr(lcFormTextWork, " ")
        lcPart = getNextSubstr(lcFormTextWork, " ")
        If VBA.InStr(lcPart, "!") <> 0 Then
            pageName = VBA.Mid(lcPart, 1, VBA.InStr(lcPart, "!") - 1)
            lcPart = VBA.Mid(lcPart, VBA.InStr(lcPart, "!") + 1)
        Else
            pageName = ""
        End If
        lnNumRow = ActiveSheet.Range(lcPart).row
        linkGraf = ActiveSheet.Range(lcPart).column - 2
        sumFlag = IIf(VBA.InStr(lcPart, ":") <> 0, True, False)
        If Not sumFlag Then
            str = str + lcZnak + IIf(pageName <> "", pageName + "!", "") + getCode(lnNumRow, "", pageName) + " " + VBA.Trim(VBA.str(linkGraf))
            If (mode And 1) <> 0 Then
                lNumber = Sheets(IIf(pageName <> "", pageName, Sheets("Service").Range("B19").Text)).Range(lcPart).Value
                str = str + " : " + lcZnak + " " + VBA.Trim(VBA.Format(lNumber, "##0.00"))
            End If
        Else
            lcZnak = lcZnak + " СУММ"
            lnNumRow = VBA.Val(VBA.Mid(lcPart, VBA.InStr(VBA.InStr(lcPart, ":"), lcPart, "$") + 1, VBA.InStr(lcPart, ")") - VBA.InStr(VBA.InStr(lcPart, ":"), lcPart, "$") - 1))
            lnNumRow1 = VBA.Val(VBA.Mid(lcPart, VBA.InStr(lcPart, "$") + 1, VBA.InStr(lcPart, ":") - VBA.InStr(lcPart, "$") - 1))
            
            str = str + lcZnak + "(" + getCode(lnNumRow1) + ":" + getCode(lnNumRow) + ")"
        End If
        str = str + " | "
Wend
getCellCode = str
Exit Function
doError:
    Call ERROR_EVENT("getCellCode")
End Function
' -------------------------------------------------------------------------------------------------------
' EdiS\07.10.10\bugs-16042
' -------------------------------------------------------------------------------------------------------
Function convertForm(str As String) As String
On Error GoTo doError
Dim pos As Integer, i As Integer
Dim newStr As String
    pos = InStr(1, str, "=")
    While pos <> 0
        str = VBA.Left(str, pos - 1) + " LIKE " + VBA.Mid(str, pos + 1, Len(str))
        i = InStr(pos, str, """")
        str = VBA.Left(str, i - 1) + "''''" + VBA.Mid(str, i + 1, Len(str))
        i = InStr(pos, str, """")
        str = VBA.Left(str, i - 1) + "%''''" + VBA.Mid(str, i + 1, Len(str))
        pos = InStr(1, str, "=")
    Wend

    pos = InStr(1, str, "TOPER")
    If pos > 0 Then
        While pos <> 0
            newStr = VBA.Mid(str, pos + 6) 'конец строки
            str = VBA.Mid(str, 1, pos - 1) + "OPER IN(SELECT T.OPER FROM S_OPER S, T_OPER_DICT T WHERE S.LINK = T.OPER_DICT AND S.CODE "
            pos = InStr(newStr, ")")
            newStr = VBA.Left(newStr, pos) + " ) " + VBA.Mid(newStr, pos + 1)
            str = str + newStr
            pos = InStr(1, str, "TOPER")
        Wend
    End If
    pos = InStr(1, str, "TCORR1")
    If pos > 0 Then
        str = Replace_in_Str(str, "TCORR1", "CORR1 IN(SELECT T.CORR FROM S_CORR S, T_CORR_DICT T WHERE S.LINK = T.CORR_DICT AND S.INN ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    pos = InStr(1, str, "TCORR2")
    If pos > 0 Then
        str = Replace_in_Str(str, "TCORR2", "CORR2 IN(SELECT T.CORR FROM S_CORR S, T_CORR_DICT T WHERE S.LINK = T.CORR_DICT AND S.INN ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    pos = InStr(1, str, "TCORRACC1")
    If pos > 0 Then
        str = Replace_in_Str(str, "TCORRACC1", "ACC1 IN(SELECT SA.LINK FROM S_CORR S, T_CORR_DICT T, S_ACCOUNT SA WHERE S.LINK = T.CORR_DICT AND T.CORR = SA.CORR AND S.INN ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    pos = InStr(1, str, "TCORRACC2")
    If pos > 0 Then
        str = Replace_in_Str(str, "TCORRACC2", "ACC2 IN(SELECT SA.LINK FROM S_CORR S, T_CORR_DICT T, S_ACCOUNT SA WHERE S.LINK = T.CORR_DICT AND T.CORR = SA.CORR AND S.INN ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    pos = InStr(1, str, "TACC1TYPE")
    If pos > 0 Then
        str = Replace_in_Str(str, "TACC1TYPE", "ACC1 IN(SELECT T.ACCOUNT FROM S_ACCOUNT SA, T_ACC_DICT T WHERE  SA.LINK = T.ACCOUNT_DICT AND SA.ACCOUNT ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    pos = InStr(1, str, "TACC2TYPE")
    If pos > 0 Then
        str = Replace_in_Str(str, "TACC2TYPE", "ACC2 IN(SELECT T.ACCOUNT FROM S_ACCOUNT SA, T_ACC_DICT T WHERE  SA.LINK = T.ACCOUNT_DICT AND SA.ACCOUNT ")
        pos = InStr(pos, str, ")")
        str = VBA.Left(str, pos) + " ) " + VBA.Mid(str, pos + 1, Len(str))
    End If
    str = Replace_in_Str(str, """", "''''")
    convertForm = VBA.Trim(Replace_in_Str(str, "ТОЧНО", "="))
Exit Function
doError:
    Call ERROR_EVENT("convertForm")
End Function
'---------------------------------------------------------------------------------------------------------------
