Attribute VB_Name = "repmaker_t"
'
' 07.07.2004 Возможность печатать более 50 групп, получать значение предыдущей группы
' 11.03.2004 Добавлен скроллинг на ячейку [a1]
' 10.03.2004 Для ячеек начинающихся на >>> ставится свойство переносить по словам принудительно
' 10.03.2004 Подправления Титова
' 19.02.2004 обработка настройки [O2] ("1251" или "866")
' 04.12.2002 в GetAligmentString добавлена проверка на длину строки
'
Option Private Module
Option Explicit
Public repPath As String, repName As String, Er As Integer, lnLastRowsCount As Long, _
       dbPath As String, dbSelect As String, dbSelectGroup As String, lcAddParam As String, lcAddModule As String, _
       wsd As Object, wso As Object, wsr As Object, wsh As Object, _
       rCurRow As Range, rStartRow As Range, rEndRow As Range, rGroupOrderRange As Range, rCurentRange As Range, _
       lnBits As Byte, SheetFieldName As String, lcAddModuleFunc As String, lcAddModuleFuncArg As String, _
       rStartGroup As Range, rEndGroup As Range, _
       columnsCount As Integer, rowsCount As Long, groupCount As Integer, _
       curPosD As Long, curPosR As Long, curGroup As Integer, _
       gStartPosD(51) As Long, gEndPosD(51) As Long, _
       gStartPosH(51) As Long, gEndPosH(51) As Long, _
       gStartPosF(51) As Long, gEndPosF(51) As Long, _
       gStartPosDet As Long, gEndPosDet As Long, _
       gVal(51), lnOldDisplayZeros As Boolean, _
       nxlFreezePanes As Boolean, nxlPages As Boolean, nxlDateTime As Boolean, _
       nxlLeftHeader As String, nxlCenterHeader As String, nxlRightHeader As String, _
       DataStartRow As Long, GroupStartRow As Long, _
       lcWsoName As String, _
       lcAddModuleFunc2 As String, lcAddModuleFuncArg2 As String, lbStat As Boolean, _
       dTime1 As Date, dTime2 As Date, nTimeDiff As Integer, dTimeBegin As Date, dTimePage As Date, dTimeAllPage As Date, _
       lcLogFile As String, lnLogMode As Integer, SheetFieldColumn As Integer, _
       wsoRange As Range, _
       groupProp(51, 15) '0-поле, 1-столбец, 2-нов.лист, 3-нов.страница, 4-символы гр., 5-скв.строки, 6-закрепление области
'добавлено 07.07.2004
Public rStartPredGroup As Range, rEndPredGroup As Range, nStartPredGroup As Long, nEndPredGroup As Long, _
       rPredGroupValue As Range, cPredGroupValue As String, _
       rPredGroupName As Range
       
Public Type TCell
    text As String
    rowspan As Integer
    colspan As Integer
    wrap As Boolean
    countLN As Integer
    curLN As Integer
    leftB As Boolean
    rightB As Boolean
    topB As Boolean
    bottomB As Boolean
    h_align As Integer
    v_align As Integer
    twitdh As Integer
    firstRow As Integer
    firstCol As Integer
    textCol As Integer
    marged As Boolean
End Type
Public Type TRow
    tc(256) As TCell
    countTC As Integer
    wrap As Boolean
    topB As Boolean
    bottomB As Boolean
End Type

Public tr(100) As TRow, col_width(256) As Integer

Public lcWorkBook As String, lcWebDir As String, _
    WebSheetsCount As Integer, _
    lcWebSheetFile As String, lcWebSheetName As String, _
    wsoColCount As Integer, _
    lcTxtCode As String
       
Sub MakeReport()
Dim ws As Object, lcString As String, lnPos As Integer, c As Range, r As Range, _
    d1 As Date, d2 As Date, d As Date, i As Long, j As Long, _
    lcField As String, lcRepSheets As String, lnRepSheet As Integer

    lbStat = True                       ' писать статистику
    lcLogFile = "c_repmaker.log"        ' файл статистики
    lnLogMode = 1                       ' 0 - создавать файл заново, 1 - добавлять

    DataStartRow = 10
    Application.ScreenUpdating = False
    If Application.ThisWorkbook.Windows(1).Visible Then
        Application.Calculation = xlCalculationManual
    End If
    Application.DisplayAlerts = False
    
    repPath = Trim(ThisWorkbook.Sheets(1).[a2].Value)
    repPath = repPath + IIf(repPath <> "", IIf(Mid(repPath, Len(repPath), 1) = "\", "", "\"), "")
    repName = Trim(ThisWorkbook.Sheets(1).[B2].Value)
    dbPath = Trim(ThisWorkbook.Sheets(1).[C2].Value)
    If dbPath <> "" Then
        dbPath = dbPath + IIf(Mid(dbPath, Len(dbPath), 1) = "\", "", "\")
    End If
    
  
    nxlFreezePanes = ThisWorkbook.Sheets(1).[G2].Value
    nxlPages = ThisWorkbook.Sheets(1).[H2].Value
    nxlLeftHeader = ThisWorkbook.Sheets(1).[K2].Value
    nxlCenterHeader = ThisWorkbook.Sheets(1).[L2].Value
    nxlRightHeader = ThisWorkbook.Sheets(1).[M2].Value
    lcAddParam = Trim(ThisWorkbook.Sheets(1).[f2].Value)
    lcTxtCode = Trim(ThisWorkbook.Sheets(1).[O2].Value)

    lcAddModule = GetStrParam(lcAddParam, 3)
    If lcAddModule <> "" Then
        Application.ThisWorkbook.VBProject.VBComponents.Import (Application.ThisWorkbook.Path + "\MODULES\" + lcAddModule)
    End If
    lnBits = Val(GetStrParam(lcAddParam, 1))
    SheetFieldName = GetStrParam(lcAddParam, 2)
    lcAddModuleFunc = GetStrParam(lcAddParam, 4)
    lcAddModuleFuncArg = GetStrParam(lcAddParam, 5)

'    If SheetFieldName <> "" Then
'        If Trim(ThisWorkbook.Sheets(1).[d2].Value) = "" Then
'            ThisWorkbook.Sheets(1).[d2].Value = SheetFieldName
'        Else
'            ThisWorkbook.Sheets(1).[d2].Value = SheetFieldName + ", " + ThisWorkbook.Sheets(1).[d2].Value
'        End If
'    End If
    
    dbSelect = Trim(ThisWorkbook.Sheets(1).[d2].Value)


    If lbStat Then
        lcLogFile = dbPath + lcLogFile
        Call PrintFile(lcLogFile, lnLogMode, "")
        Call PrintFile(lcLogFile, 1, "Формирование отчета " & repPath & repName)
        dTime1 = Time()
        dTimeBegin = dTime1
     End If

    ' Открываем шаблон документа
    Workbooks.Open fileName:=repPath + repName
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Range("A1").Select

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Открытие шаблона")
    End If
    
'txt -------------------------------------------------------
    lcWorkBook = ActiveWorkbook.name
    If InStr(lcWorkBook, ".xl") > 0 Then lcWorkBook = Mid(lcWorkBook, 1, InStr(lcWorkBook, ".xl") - 1)

    If Trim(SheetFieldName) = "" Then
        lcWebDir = lcWorkBook + ".files\"
        On Error GoTo Err_MkDir:
        If Dir(dbPath + lcWebDir, vbDirectory) <> "" Then
            Kill (dbPath + lcWebDir + "*.*")
            RmDir (dbPath + lcWebDir)
        End If
        MkDir (dbPath + lcWebDir)
Err_MkDir:
        On Error GoTo 0
    Else
        lcWebDir = ""
    End If

    WebSheetsCount = 0
'/txt ------------------------------------------------------

    Set wso = Application.ActiveWorkbook.ActiveSheet

    ' Добавляем модуль FUNCTIONS.BAS
    Application.ActiveWorkbook.VBProject.VBComponents.Import (Application.ThisWorkbook.Path + "\MODULES\function.bas")
    ' Добавили лист для данных
    Application.ActiveWorkbook.Worksheets.Add
    Set wsd = Application.ActiveWorkbook.ActiveSheet
    wsd.name = "Данные"

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Импорт модуля function.bas")
    End If

    lcRepSheets = ""
    ' Добавляем группы из листа "Группы"
    For Each ws In Application.ActiveWorkbook.Worksheets
        If ws.name = "Группы" Then
            lcString = ws.Cells(1, 1).Value
            Set c = ws.Cells(LastCell(ws.Cells).Row + 1, 1)
            Call LoadTable(c, lcString)
            lcString = wso.[f1]
            
            gEndPosH(0) = 0       ' Конечная строка шапки группы
            groupCount = ws.Cells(1, 2)
            For i = 1 To groupCount
                gStartPosH(i) = gEndPosH(i - 1) + 2 ' Начальная строка шапки группы
                gEndPosH(i) = gEndPosH(i - 1) + 1
                Do While Not (ws.Cells(gEndPosH(i) + 1, 1).Value Like "^ Шапка*")
                    gEndPosH(i) = gEndPosH(i) + 1
                Loop
                groupProp(i, 0) = ws.Cells(gEndPosH(i) + 1, 2).Value
            Next i
            
            gEndPosF(groupCount + 1) = gEndPosH(groupCount) ' Конечная строка концовки группы
            For i = groupCount To 1 Step -1
                gStartPosF(i) = gEndPosF(i + 1) + 2 ' Начальная строка концовки группы
                gEndPosF(i) = gEndPosF(i + 1) + 1
                Do While Not (ws.Cells(gEndPosF(i) + 1, 1).Value Like "^ Концовка*")
                    gEndPosF(i) = gEndPosF(i) + 1
                Loop
            Next i
            
            gEndPosDet = wso.Cells.Find("^ Данные", LookIn:=xlValues, LookAt:=xlWhole).Row
            gStartPosDet = gEndPosDet
            Do While Not (wso.Cells(gStartPosDet - 1, 1).Value Like "^ Шапка*")
                gStartPosDet = gStartPosDet - 1
            Loop
            
            For i = 1 To rowsCount
                lcField = c.Offset(i - 1, 0).Value
                lcString = lcString + IIf(lcString = "", "", ", ") + lcField
                j = 1
                Do While (Not UCase(groupProp(j, 0)) = UCase(lcField)) And (j <= groupCount)
                    j = j + 1
                Loop
                If j <= groupCount Then
                    ws.Rows(Trim(Str(gStartPosH(j))) + ":" + Trim(Str(gEndPosH(j) + 1))).Copy
                    wso.Rows(gStartPosDet).Insert Shift:=xlDown
                    gStartPosDet = gStartPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                    gEndPosDet = gEndPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                    ws.Rows(Trim(Str(gStartPosF(j))) + ":" + Trim(Str(gEndPosF(j) + 1))).Copy
                    wso.Rows(gEndPosDet + 1).Insert Shift:=xlDown
                    wso.[B1] = wso.[B1] + 1
                End If
            Next i
            If ws.[f1] <> "" Then
                lcString = ws.[f1] + IIf(lcString = "", "", ", ") + lcString
            End If
            wso.[f1] = lcString
            wso.Activate
            ws.Delete

            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Добавление группировки")
            End If
        Else
            If ws.Visible = True Then lcRepSheets = lcRepSheets + ws.name + "#"
        End If
    Next ws
    Set ws = Nothing
    Set c = Nothing

    Call LoadNastr(wsd.[a1])
    wso.Cells.Calculate
'    wso.[C1].Calculate
'    wso.[D1].Calculate
'    wso.[E1].Calculate
'    wso.[F1].Calculate

    lcString = wso.[C1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "SELECT", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 6) + lcString + ", " + Mid(dbSelect, lnPos + 7)
        End If
    End If

    lcString = wso.[D1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "FROM", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 4) + lcString + ", " + Mid(dbSelect, lnPos + 5)
        End If
    End If

    lcString = wso.[E1]
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "WHERE", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos + 5) + lcString + " AND " + Mid(dbSelect, lnPos + 6)
        Else
            lnPos = InStr(1, dbSelect, "ORDER BY", 1)
            If lnPos > 0 Then
                dbSelect = Mid(dbSelect, 1, lnPos - 1) + " WHERE " + lcString + " " + Mid(dbSelect, lnPos)
            Else
                dbSelect = dbSelect + " WHERE " + lcString
            End If
        End If
    End If

    lcString = wso.[f1]
        If SheetFieldName <> "" Then
            lcString = SheetFieldName + IIf(lcString <> "", ", " + lcString, "")
        End If
    If lcString <> "" Then
        lnPos = InStr(1, dbSelect, "ORDER BY", 1)
        If lnPos > 0 Then
            dbSelect = Mid(dbSelect, 1, lnPos - 1) + " ORDER BY " + lcString
        Else
            dbSelect = dbSelect + " ORDER BY " + lcString
        End If
    End If

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Загрузка настроек")
    End If

    DataStartRow = 10 + rowsCount

    ' Загружаем данные
    Er = 0
    Call LoadData

    If lbStat Then
        dTime2 = Time()
        nTimeDiff = DateDiff("s", dTime1, dTime2)
        dTime1 = dTime2
        Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Загрузка данных")
    End If

    If Er = 0 Then
        lnRepSheet = 1
        While GetStrParam(lcRepSheets, lnRepSheet) <> ""
            lcWsoName = GetStrParam(lcRepSheets, lnRepSheet)
            If lcWsoName <> "Данные" Then
                Set wso = ActiveWorkbook.Worksheets(lcWsoName)
                
                lcAddModuleFunc2 = wso.[H1]
                lcAddModuleFuncArg2 = wso.[I1]
                ' Преобразование полей
                Application.StatusBar = "Подготовка к формированию отчета..."
                
                Call f1
                lnLastRowsCount = wso.[g1]

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Подготовка групп")
                End If

                Call ValuesColumns(wso.Range(wso.[a1], LastCell(wso.[a1])))

                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Размножение столбцов по значениям")
                End If
                
'Титов
                Call DubleColumns(wso.Range(wso.[a1], LastCell(wso.[a1])))

                Call f1_2
'txt -------------------------------------------------------
                WebSheetsCount = WebSheetsCount + 1
                lcWebSheetName = wso.name + "_" + Trim(Str(WebSheetsCount))
                SheetFieldColumn = 0
                If SheetFieldName <> "" Then
                    wsd.Activate
                    Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(SheetFieldName, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        SheetFieldColumn = c.column
                        lcWebSheetName = wsd.Cells(DataStartRow, SheetFieldColumn)
                        lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                        lcWebSheetFile = IIf(lcAddModuleFuncArg <> "", lcAddModuleFuncArg, dbPath + lcWebDir) + lcWebSheetName
                        If InStr(1, lcWebSheetFile, ".") = 0 Then lcWebSheetFile = lcWebSheetFile + ".txt"
                    Else
                        lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                        lcWebSheetFile = IIf(lcAddModuleFuncArg <> "", lcAddModuleFuncArg, dbPath + lcWebDir) + lcWebSheetName + ".txt"
                    End If
                    wso.Activate
                End If
'/txt ------------------------------------------------------
                wso.Activate
                Set wsoRange = Range(Cells(1, 1), LastCell(Cells))
                Call RedefineFields(wsoRange)
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Подготовка формул")
                End If
'txt -------------------------------------------------------
                wsoColCount = wsoRange.Columns.count
                Call InitTRows(wsoRange)
                Call InitSheet
                Call PrintFile(lcWebSheetFile, 0, "")
                curPosR = 1
'/txt ------------------------------------------------------
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Создание библиотеки стилей")
                End If
                ' Формирование отчета
                Application.StatusBar = "Формирование документа (0%)"
                Call f2(1)
'txt -------------------------------------------------------
                Call PrintFile(lcWebSheetFile, 1, GetTXTLastLine(wsoRange))
'/txt ------------------------------------------------------
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Формирование листов отчета в txt")
                End If
                wso.Delete
            End If
            lnRepSheet = lnRepSheet + 1
        Wend
    End If
    Application.DisplayAlerts = False
    wsd.Parent.Close
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Visible = True
    Application.ScreenUpdating = True
    If Application.ThisWorkbook.Windows(1).Visible Then
        Application.Calculation = xlCalculationAutomatic
        Application.ActiveWorkbook.Saved = True
    End If
    Application.ThisWorkbook.Windows(1).Visible = False
    Application.ThisWorkbook.Saved = True
    If lbStat Then
        dTime2 = Time()
        Call PrintFile(lcLogFile, 1, "Всего на создание отчета: " & DateDiff("s", dTimeBegin, dTime2) & " сек")
    End If
    If (lnBits And 2) > 0 Then
        Application.ThisWorkbook.Close
    End If
End Sub

Sub MinimizeWindow()
    Application.WindowState = xlMinimized
End Sub

Sub NormalizeWindow()
    Application.WindowState = xlMinimized
    Application.WindowState = xlNormal
End Sub

Sub LoadData()
Dim startRange As Range, qt As QueryTable, odbcDriver As String, odbcstr As String, n As Integer
    Application.StatusBar = "Загрузка рабочих данных..."
    wsd.Activate
    Set startRange = wsd.Cells(DataStartRow - 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, dbSelect)
    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
    If rowsCount <= 2 Then
        rowsCount = 0
        Do While Not IsEmptyRange(wsd.Range(Cells(rowsCount + DataStartRow, 1), Cells(rowsCount + DataStartRow, columnsCount)))
            rowsCount = rowsCount + 1
        Loop
    End If
    If rowsCount = 0 Then
        GoTo Err2
    End If
    ' Присвоение имен
    wsd.Parent.Names.Add name:="Data", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(rowsCount + DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add name:="DataFields", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add name:="CurRow", RefersToR1C1:="=Данные!R1C1"
    wsd.Parent.Names.Add name:="StartRow", RefersToR1C1:="=Данные!R1C2"
    wsd.Parent.Names.Add name:="EndRow", RefersToR1C1:="=Данные!R1C3"
    wsd.Parent.Names.Add name:="CurentGroup", RefersToR1C1:="=Данные!R1C4"
    wsd.Parent.Names.Add name:="GroupOrder", RefersToR1C1:="=Данные!R1C10"
    wsd.Parent.Names.Add name:="StartData", RefersToR1C1:="=Данные!R1C5"

    For n = 1 To 50
        wsd.Parent.Names.Add Name:="Start" + Trim(Str(n)), RefersToR1C1:="=Данные!R1C" + Trim(Str(10 + n))
        wsd.Parent.Names.Add Name:="End" + Trim(Str(n)), RefersToR1C1:="=Данные!R1C" + Trim(Str(60 + n))
    Next n

    Set rCurRow = wsd.[a1]
    Set rStartRow = wsd.[B1]
    Set rEndRow = wsd.[C1]
    Set rCurentRange = wsd.[d1]
    Set rGroupOrderRange = wsd.[j1]
    Set rStartGroup = wsd.Cells(1, 11)
    Set rEndGroup = wsd.Cells(1, 61)

'добавлено 07.07.2004
    wsd.Parent.Names.Add Name:="StartPred", RefersToR1C1:="=Данные!R1C254"
    wsd.Parent.Names.Add Name:="EndPred", RefersToR1C1:="=Данные!R1C255"
    Set rStartPredGroup = wsd.Cells(1, 254)
    Set rEndPredGroup = wsd.Cells(1, 255)
    wsd.Parent.Names.Add Name:="PrevGroupValue", RefersToR1C1:="=Данные!R1C253"
    Set rPredGroupValue = wsd.Cells(1, 253)

    wsd.Parent.Names.Add Name:="PrevGroupName", RefersToR1C1:="=Данные!R1C252"
    Set rPredGroupName = wsd.Cells(1, 252)

    rPredGroupValue.NumberFormat = "@"
    cPredGroupValue = "#####"
    nStartPredGroup = 0
    rEndPredGroup = 0

    wsd.[E1] = DataStartRow
    GoTo ExitProc
Err1:
    n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
    GoTo ExitProc
Err2:
    n = MsgBox("Нет данных для печати!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
ExitProc:
    Set startRange = Nothing
    Set qt = Nothing
End Sub

Function IsEmptyRange(loRange) As Boolean
    Dim i, llEmpty
    llEmpty = True
    For i = 1 To loRange.count
        llEmpty = llEmpty And IsEmpty(loRange.Item(i))
    Next i
    IsEmptyRange = llEmpty
End Function

Sub ValuesColumns(curRange As Range)
Dim c As Range, n1 As Integer, n2 As Integer, n3 As Integer, lnRCount As Integer, lnCCount As Integer, lcComm As String, _
    lcSelect As String, lcFieldValues As String, lcFieldRepl As String, lcWhat As String, loCell As Range, _
    wsv As Object, qt As QueryTable, lcRepl As String

    Do
        Set c = curRange.Find("&&", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            lcComm = c.Value
            n1 = InStr(1, lcComm, "#")
            n2 = InStr(n1 + 1, lcComm, "#")
            n3 = InStr(n2 + 1, lcComm, "#")
            lcSelect = Mid(lcComm, 3, n1 - 3)
            lcFieldValues = Mid(lcComm, n1 + 1, n2 - n1 - 1)
            lcFieldRepl = Mid(lcComm, n2 + 1, n3 - n2 - 1)
            lcWhat = Mid(lcComm, n3 + 1, Len(lcComm) - n3)


            Application.ActiveWorkbook.Worksheets.Add
            Set wsv = Application.ActiveWorkbook.ActiveSheet

            wsv.Activate
            Set qt = wsv.QueryTables.Add("ODBC;" + _
                "Driver=" + GetODBCDriver() + ";" + _
                "UID=admin;SourceType=DBF;" + _
                "DefaultDir=" + dbPath + "\;" + _
                "DBQ=" + dbPath + "\;" + _
                "SourceDB=" + dbPath + "\;", Cells(1, 1), lcSelect)
            
            qt.BackgroundQuery = False
            qt.FieldNames = True
            On Error GoTo ErrV
            qt.Refresh
            On Error GoTo 0
            lnCCount = qt.ResultRange.Columns.count
            lnRCount = qt.ResultRange.Rows.count - 1
            If lnRCount <= 2 Then
                lnRCount = 0
                Do While Not IsEmptyRange(wsv.Range(Cells(lnRCount + 2, 1), Cells(lnRCount + 2, lnCCount)))
                    lnRCount = lnRCount + 1
                Loop
            End If
            
            n1 = 1 'Столбец поля значений
            n2 = 1 'Столбец поля замены
            For n3 = 1 To lnCCount
                If UCase(Cells(1, n3).Value) = UCase(lcFieldValues) Then n1 = n3
                If UCase(Cells(1, n3).Value) = UCase(lcFieldRepl) Then n2 = n3
            Next n3
            wso.Activate
            For n3 = 1 To lnRCount - 1
                Call Duble(c)
                c.Offset(0, -1).Select
                Set loCell = Selection.Cells(1, 1)
                Call ReplaceMask(loCell, wsv.Cells(n3 + 1, n1).Value, lcWhat, wsv.Cells(n3 + 1, n2).Value)
            Next n3
            Call ReplaceMask(c, wsv.Cells(n3 + 1, n1).Value, lcWhat, wsv.Cells(n3 + 1, n2).Value)
            
            GoTo ExitV
ErrV:
            n1 = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
            Er = -1
ExitV:
            Application.DisplayAlerts = False
            wsv.Delete
        End If
    Loop Until c Is Nothing
    Set c = Nothing
    Set wsv = Nothing
    Set loCell = Nothing
    Set qt = Nothing
End Sub

Sub DubleColumns(curRange As Range)
Dim c As Range
    Do
        Set c = curRange.Find("#(", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Call DubleMaskFields(c)
        End If
    Loop Until c Is Nothing
    Set c = Nothing
End Sub

Sub DubleRows(curRange As Range)
Dim c As Range
    Do
        Set c = curRange.Find("##(", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Call DubleRowMaskFields(c)
        End If
    Loop Until c Is Nothing
    Set c = Nothing
End Sub

Sub RedefineFields(curRange As Range)
Dim i As Long, j As Integer, c As Range, fName As String, frange As String, fval As String, fnrange As String, _
        frange2 As String, frange3 As String

'    Application.StatusBar = "Преобразование полей..."
    For i = 1 To columnsCount
        fName = wsd.Cells(DataStartRow - 1, i).Value   ' Имя поля

        wsd.Parent.Names.Add Name:=fname, RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 3)) + "C" + Trim(Str(0 + i))
        wsd.Cells(DataStartRow - 3, 0 + i).Value="-1"
        wsd.Parent.Names.Add Name:="IsUp_" + fName, RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 5)) + "C" + Trim(Str(0 + i))
        wsd.Cells(DataStartRow - 5, 0 + i).Value = False

        fval = "ДВССЫЛ(""Данные!R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        fnrange = "ДВССЫЛ(""Данные!R"" & StartData & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        frange2 = "ДВССЫЛ(""Данные!R"" & StartRow & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
        frange3 = "ДВССЫЛ(""Данные!R"" & StartData & ""C" & i & ":R"" & CurRow-1 & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="{" + fName + "}", Replacement:=fval, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

        If Not (curRange.Find(">(", LookIn:=xlValues, LookAt:=xlPart) Is Nothing) Then
            For j = 1 To groupCount
                frange = "ДВССЫЛ(""Данные!R"" & Start" + Trim(Str(j)) + " & ""C" & i & ":R"" & End" + Trim(Str(j)) + " & ""C" & i & """;ЛОЖЬ)"
                curRange.Replace What:="<" + fName + ">(" + Trim(Str(j)) + ")", Replacement:=frange, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, MatchCase:=False ' Замена
            Next j
        End If

'добавлено 07.07.2004
        frange = "ДВССЫЛ(""Данные!R"" & StartPred & ""C" & i & ":R"" & EndPred & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="<" + fName + ">(Prev)", Replacement:=frange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

        frange = "ДВССЫЛ(""Данные!R"" & StartRow & ""C" & i & ":R"" & EndRow & ""C" & i & """;ЛОЖЬ)"
        curRange.Replace What:="<" + fName + ">", Replacement:=frange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
        curRange.Replace What:="/" + fName + "/", Replacement:=frange2, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
        curRange.Replace What:="\" + fName + "\", Replacement:=frange3, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена

        If Not (curRange.Find("](", LookIn:=xlValues, LookAt:=xlPart) Is Nothing) Then
            For j = 1 To groupCount
                frange = "ДВССЫЛ(""Данные!R"" & Start" + Trim(Str(j)) + " & ""C" & i & ":R"" & CurRow & ""C" & i & """;ЛОЖЬ)"
                curRange.Replace What:="[" + fName + "](" + Trim(Str(j)) + ")", Replacement:=frange, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, MatchCase:=False ' Замена
            Next j
        End If

        curRange.Replace What:="[" + fName + "]", Replacement:=fnrange, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False ' Замена
    Next i

End Sub

Sub f1()
Dim i As Long, c As Range, lB As Boolean
'    Application.StatusBar = "Подготовка к формированию отчета..."
    wsd.Select
    curPosD = DataStartRow
    gStartPosD(0) = DataStartRow
    groupCount = wso.[B1].Value
    gEndPosH(0) = 0       ' Конечная строка шапки группы

    If SheetFieldName <> "" Then
        groupCount = groupCount + 1
    End If

    For i = 1 To groupCount
        
        If SheetFieldName <> "" And i = 1 Then
            gStartPosH(i) = 1 ' Начальная строка шапки группы
            gEndPosH(i) = 0
            groupProp(i, 0) = SheetFieldName
            Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(groupProp(i, 0), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                groupProp(i, 1) = c.Column
            Else
                groupProp(i, 1) = 0
            End If
            groupProp(i, 14) = SheetFieldName
            groupProp(i, 2) = True
            groupProp(i, 3) = True
            groupProp(i, 4) = False
            groupProp(i, 5) = False
            groupProp(i, 6) = False
            groupProp(i, 7) = True  'Группа начинается на новом листе
            groupProp(i, 8) = True  'Группа начинается на новой странице
            groupProp(i, 9) = ""   'Дополнительная команда
            groupProp(i, 10) = 0    ' Строка начала группы в выходном отчете
            groupProp(i, 11) = 0    ' Номер группы
            groupProp(i, 12) = "" ' Условие вывода
        Else
            gStartPosH(i) = gEndPosH(i - 1) + 2 ' Начальная строка шапки группы
            gEndPosH(i) = gEndPosH(i - 1) + 1
            Do While Not (wso.Cells(gEndPosH(i) + 1, 1).Value Like "^ Шапка*")
                gEndPosH(i) = gEndPosH(i) + 1
            Loop
            groupProp(i, 0) = wso.Cells(gEndPosH(i) + 1, 2).Value
            Set c = wsd.Range(Cells(DataStartRow - 1, 1), Cells(DataStartRow - 1, columnsCount)).Find(groupProp(i, 0), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                groupProp(i, 1) = c.Column
            Else
                groupProp(i, 1) = 0
            End If
            groupProp(i, 14) = wso.Cells(gEndPosH(i) + 1, 2).Value
            groupProp(i, 2) = wso.Cells(gEndPosH(i) + 1, 3).Value
            groupProp(i, 3) = wso.Cells(gEndPosH(i) + 1, 4).Value
            groupProp(i, 4) = wso.Cells(gEndPosH(i) + 1, 5).Value
            groupProp(i, 5) = wso.Cells(gEndPosH(i) + 1, 6).Value
            lB = wso.Cells(gEndPosH(i) + 1, 7).Value
            groupProp(i, 6) = lB
            groupProp(i, 7) = True  'Группа начинается на новом листе
            groupProp(i, 8) = True  'Группа начинается на новой странице
            groupProp(i, 9) = wso.Cells(gEndPosH(i) + 1, 9).Value   'Дополнительная команда
            groupProp(i, 10) = 0    ' Строка начала группы в выходном отчете
            groupProp(i, 11) = 0    ' Номер группы
            groupProp(i, 12) = wso.Cells(gEndPosH(i) + 1, 8).Value ' Условие вывода
        End If
        
    Next i
    gStartPosDet = gEndPosH(groupCount) + 2 ' Начальная строка Detail
    gEndPosDet = gEndPosH(groupCount) + 1   ' Конечная строка Detail
    Do While Not (wso.Cells(gEndPosDet + 1, 1).Value Like "^ Данные*")
        gEndPosDet = gEndPosDet + 1
    Loop
    groupProp(0, 12) = wso.Cells(gEndPosDet + 1, 8).Value ' Условие вывода
    gEndPosF(groupCount + 1) = gEndPosDet          ' Конечная строка концовки группы
    For i = groupCount To 1 Step -1
    
        If SheetFieldName <> "" And i = 1 Then
            gStartPosF(i) = gEndPosF(i + 1) + 1
            gEndPosF(i) = gEndPosF(i + 1)
        Else
            gStartPosF(i) = gEndPosF(i + 1) + 2 ' Начальная строка концовки группы
            gEndPosF(i) = gEndPosF(i + 1) + 1
            Do While Not (wso.Cells(gEndPosF(i) + 1, 1).Value Like "^ Концовка*")
                gEndPosF(i) = gEndPosF(i) + 1
            Loop
            groupProp(i, 13) = wso.Cells(gEndPosF(i) + 1, 8).Value ' Условие вывода
        End If
        
    Next i
    gEndPosD(0) = rowsCount + DataStartRow - 1
    Set c = Nothing
End Sub

Sub f1_2()
    Dim i As Long
    wso.Cells(gEndPosDet + 1, 8).Value = groupProp(0, 12)
    For i = 1 To groupCount
        wso.Cells(gEndPosH(i) + 1, 8).Value = groupProp(i, 12)
        wso.Cells(gEndPosF(i) + 1, 8).Value = groupProp(i, 13)
    Next i
End Sub


Sub f2(ByVal curGr As Integer)      ' curGr - Текущая группа
Dim startPosGr As Long, endPosGr As Long, c As Range, b As Boolean, i As Long, bNotPrint As Boolean, _
    oSheet As Object, cSheetName As String, bNew As Boolean, cNewSheet As String, lcFormula As String
    Do
        groupProp(curGr, 11) = groupProp(curGr, 11) + 1
        rGroupOrderRange = curGr
        rCurentRange = groupProp(curGr, 11)
        gStartPosD(curGr) = curPosD ' Начальная строка данных
        rStartGroup.Offset(0, curGr - 1).Value = curPosD

        If groupProp(curGr, 1) > 0 Then ' Если столбец группировки не 0 (не отчет)
            gVal(curGr) = wsd.Cells(curPosD, groupProp(curGr, 1)).Value ' Значение столбца группы

            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.NumberFormat = "@"
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.Value = gVal(curGr)

            ' добавлено 16/08/2006
            wsd.Parent.Names("IsUp_" + groupProp(curGr, 0)).RefersToRange.Value = True

            gEndPosD(curGr) = curPosD   ' Конечная строка данных
            Do While (gEndPosD(curGr) <> gEndPosD(curGr - 1)) And _
                (wsd.Cells(gEndPosD(curGr) + 1, groupProp(curGr, 1)).Value = gVal(curGr))
                gEndPosD(curGr) = gEndPosD(curGr) + 1
            Loop
        Else
            gEndPosD(curGr) = gEndPosD(curGr - 1)
        End If

        rEndGroup.Offset(0, curGr - 1).Value = gEndPosD(curGr)

'добавлено 07.07.2004
        rStartPredGroup.Value = IIf(nStartPredGroup > 0, nStartPredGroup, curPosD)
        rEndPredGroup.Value = IIf(nEndPredGroup > 0, nEndPredGroup, gEndPosD(curGr))
        nStartPredGroup = curPosD
        nEndPredGroup = gEndPosD(curGr)
        rPredGroupValue.Value = IIf(cPredGroupValue <> "#####", cPredGroupValue, gVal(curGr))
        cPredGroupValue = gVal(curGr)



        rPredGroupName.Value = IIf(curGr > 1, groupProp(curGr - 1, 0), "")



        ' Создание нового листа
        If (groupProp(curGr, 2) And Not nxlPages) Or curPosR > 32000 Then
            If groupProp(curGr, 7) Then
                groupProp(curGr, 7) = False
            Else
                If SheetFieldColumn > 0 Then
                    cNewSheet = StrReplace(wsd.Cells(curPosD, SheetFieldColumn), " " , "")
                Else
                    cNewSheet = ""
                End If
                If cNewSheet <> lcWebSheetName Then
'txt -------------------------------------------------------
                    Call PrintFile(lcWebSheetFile, 1, GetTXTLastLine(wsoRange))
                
                    WebSheetsCount = WebSheetsCount + 1
                    lcWebSheetName = wso.name + "_" + Trim(Str(WebSheetsCount))
                    If SheetFieldColumn > 0 Then
                        lcWebSheetName = wsd.Cells(curPosD, SheetFieldColumn)
                        lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                        lcWebSheetFile = IIf(lcAddModuleFuncArg <> "", lcAddModuleFuncArg, dbPath + lcWebDir) + lcWebSheetName
                        If InStr(1, lcWebSheetFile, ".") = 0 Then lcWebSheetFile = lcWebSheetFile + ".txt"
                    Else
                        lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                        lcWebSheetFile = IIf(lcAddModuleFuncArg <> "", lcAddModuleFuncArg, dbPath + lcWebDir) + lcWebSheetName + ".txt"
                    End If
                
                    Call InitSheet
                    Call PrintFile(lcWebSheetFile, 0, "")
                    curPosR = 1
'/txt ------------------------------------------------------
                Else                
                    Call PrintFile(lcWebSheetFile, 1, Chr(12))
                End If

                groupProp(curGr, 8) = True
                For i = curGr + 1 To groupCount
                    groupProp(i, 7) = True
                    groupProp(i, 8) = True
                Next i
            End If
        End If
        
        groupProp(curGr, 10) = curPosR
        ' Копирование шапки группы

        rCurRow.Value = gStartPosD(curGr)
        rStartRow.Value = gStartPosD(curGr)
        rEndRow.Value = gEndPosD(curGr)

	With wso.Cells(gEndPosH(curGr) + 1, 8)
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            On Error Resume Next
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
            On Error Goto 0
        End With

'        wso.Cells(gEndPosH(curGr) + 1, 8).Calculate
'        If wso.Cells(gEndPosH(curGr) + 1, 8) <> "" Then
'            bNotPrint = wso.Cells(gEndPosH(curGr) + 1, 8)
'        Else
'            bNotPrint = True
'        End If

        If groupProp(curGr, 3) And Not nxlPages Then
            If groupProp(curGr, 8) Then
                groupProp(curGr, 8) = False
            Else
                Call PrintFile(lcWebSheetFile, 1, Chr(12))
                For i = curGr + 1 To groupCount
                    groupProp(i, 8) = True
                Next i
            End If
        End If
        
        If ((gEndPosH(curGr) - gStartPosH(curGr) + 1) > 0) And bNotPrint Then
            '!!!!!!!!!!!!!!!!!!!!!!
            Call f3(gStartPosH(curGr), gEndPosH(curGr), _
                    gStartPosD(curGr), gEndPosD(curGr), _
                    gStartPosD(curGr))
            '!!!!!!!!!!!!!!!!!!!!!!
        End If
        
        startPosGr = curPosR

        If curGr = groupCount Then
            Do
                ' Копирование Detail
                rCurRow.Value = curPosD

          	With wso.Cells(gEndPosDet + 1, 8)
                    lcFormula = .FormulaLocal
                    .FormulaLocal = lcFormula
                    .Calculate
                    On Error Resume Next
                    If .Value <> "" Then
                        bNotPrint = .Value
                    Else
                        bNotPrint = True
                    End If
                    On Error Goto 0
                End With

'                wso.Cells(gEndPosDet + 1, 8).Calculate
'                If wso.Cells(gEndPosDet + 1, 8) <> "" Then
'                    bNotPrint = wso.Cells(gEndPosDet + 1, 8)
'                Else
'                    bNotPrint = True
'                End If

                Application.StatusBar = "Формирование документа (" _
                + Trim(Str(Int((curPosD - DataStartRow + 1) / rowsCount * 100))) + "%)"

                If ((gEndPosDet - gStartPosDet + 1) > 0) And bNotPrint Then
                    '!!!!!!!!!!!!!!!!!!!!!!
                    Call f3(gStartPosDet, gEndPosDet, _
                            gStartPosD(curGr), gEndPosD(curGr), _
                            curPosD)
                    '!!!!!!!!!!!!!!!!!!!!!!
                End If
                curPosD = curPosD + 1
            Loop Until curPosD > gEndPosD(curGr)
        Else
            ' Рекурсивный вызов !!!!!!!!!!!!!
            groupProp(curGr + 1, 11) = 0
            Call f2(curGr + 1)
        End If
        endPosGr = curPosR
        ' Копирование концовки группы

        rCurRow.Value = gEndPosD(curGr)
        rStartRow.Value = gStartPosD(curGr)
        rEndRow.Value = gEndPosD(curGr)

	With wso.Cells(gEndPosF(curGr) + 1, 8)
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            On Error Resume Next
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
            On Error Goto 0
        End With

'        wso.Cells(gEndPosF(curGr) + 1, 8).Calculate
'        If wso.Cells(gEndPosF(curGr) + 1, 8) <> "" Then
'            bNotPrint = wso.Cells(gEndPosF(curGr) + 1, 8)
'        Else
'            bNotPrint = True
'        End If

        If ((gEndPosF(curGr) - gStartPosF(curGr) + 1) > 0) And bNotPrint Then
            '!!!!!!!!!!!!!!!!!!!!!!
            Call f3(gStartPosF(curGr), gEndPosF(curGr), _
                    gStartPosD(curGr), gEndPosD(curGr), _
                    gEndPosD(curGr))
            '!!!!!!!!!!!!!!!!!!!!!!
        End If
        If groupProp(curGr, 1) > 0 Then ' Если столбец группировки не 0 (не отчет)
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.NumberFormat = "@"
            wsd.Parent.Names(groupProp(curGr, 14)).RefersToRange.Value = ""
        
            ' добавлено 16/08/2006
            wsd.Parent.Names("IsUp_" + groupProp(curGr, 0)).RefersToRange.Value = False
	End If
    Loop Until (gEndPosD(curGr) = gEndPosD(curGr - 1))
    Set c = Nothing
End Sub

Sub f3(startPosRepl, endPosRepl, _
        startPosD, endPosD, curPosData)
Dim c As Range, curRange As Range, lbText As Boolean, cText As String, _
    lcFormula As String, lbMerge As Boolean



    Set curRange = wso.Range(Cells(startPosRepl, 1), Cells(endPosRepl, wsoColCount)) ' Диапазон
    rCurRow.Value = curPosData
    rStartRow.Value = startPosD
    rEndRow.Value = endPosD
'    On Error GoTo m1
    On Error Resume Next


    For Each c In curRange.SpecialCells(xlCellTypeFormulas)
        With c
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
        End With
    Next c

'    curRange.Calculate


' запись вычисленных ячеек в txt
'txt -------------------------------------------------------
    Call InitTextData(curRange)
    Call PrintFile(lcWebSheetFile, 1, GetTextBody(curRange))
'/txt ------------------------------------------------------
'm1:
    Set c = Nothing
    Set curRange = Nothing
End Sub

Sub Duble(loCellS As Range)         ' Процедура дублирует столбец (столбцы) данной ячейки
Dim loCellD As Range, i As Long  ' Ячейки исходного и сдублированного столбца,
Dim aWidth(255), oCell As Range     '   которые располагаются выше данной,
    loCellS.Select                  '   объединяются
    i = 0
    For Each oCell In Selection
        aWidth(i) = oCell.ColumnWidth
        i = i + 1
    Next oCell
    Selection.EntireColumn.Insert
    i = 0
    For Each oCell In Selection
        oCell.ColumnWidth = aWidth(i)
        i = i + 1
    Next oCell
    Set loCellD = Selection
    Range(loCellS, loCellS.Offset(LastCell(loCellS).Row, 0)).Select
    Selection.Copy Destination:=loCellD
    For i = 1 To loCellS.Row - 1
        Range(loCellD.Offset(-i, 0), loCellS.Offset(-i, 0)).MergeCells = Range(loCellD.Offset(-i, 0), loCellS.Offset(-i, 0)).Locked
    Next i
    Set loCellD = Nothing
    Set oCell = Nothing
End Sub

Sub ReplaceMask(loCellS As Range, lcValue As String, lcWhat As String, lcRepl As String)
    loCellS.Select          ' Процедура заменяет значение ячейки на lcValue и
    loCellS.Value = lcValue ' ниже этой ячейки заменяет lcWhat на lcRepl
    Range(Selection, Selection.Offset(LastCell(Selection).Row, 0)).Replace What:=lcWhat, Replacement:=lcRepl
End Sub

Sub DubleMaskFields(loCellS As Range)
Dim loCell As Range, _
    lcMask As String, lcWhat As String, i As Long, j As Integer, _
    lnField As Integer, lnStar As Integer, lnSkobka As Integer, _
    laRepl(255, 2) As String, llNastr As Boolean  'Титов
    wso.Select
    lnStar = InStr(1, loCellS.Value, "#")
    lnSkobka = InStr(lnStar + 2, loCellS.Value, ")")
    lnField = lnStar
' Титов
	llNastr= False
    Do While (Mid(loCellS.Value, lnField - 1, 1) <> "{") And (Mid(loCellS.Value, lnField - 1, 1) <> "<")
' Титов
		If Mid(loCellS.Value, lnField - 1, 1) = ">" Then
			llNastr= True
			Exit Do
		End If
        lnField = lnField - 1
    Loop
    lcWhat = Mid(loCellS.Value, lnStar + 2, lnSkobka - lnStar - 2)
    lcMask = UCase(Mid(loCellS.Value, lnField, lnStar - lnField))
    i = 0
' Титов
	If llNastr Then
		For Each loCell In wsd.Range("NastrFields")
	        If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
	            i = i + 1
	            laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
	            laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
	        End If
	    Next loCell
	Else
	    For Each loCell In wsd.Range("DataFields")
	        If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
	            i = i + 1
	            laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
	            laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
			End If
	    Next loCell
	End If
    For j = 1 To i - 1
        Call Duble(loCellS)
        loCellS.Offset(0, -1).Select
        Set loCell = Selection.Cells(1, 1)
        Call ReplaceMask(loCell, laRepl(j, 1), lcWhat, laRepl(j, 2))
    Next j
    Call ReplaceMask(loCellS, laRepl(i, 1), lcWhat, laRepl(i, 2))
    Set loCell = Nothing
End Sub

Sub DubleRowMaskFields(loCellS As Range)
Dim loCell As Range, _
    lcMask As String, lcWhat As String, i As Long, j As Integer, _
    lnField As Integer, lnStar As Integer, lnSkobka As Integer, _
    laRepl(255, 2) As String
    wso.Select
    lnStar = InStr(1, loCellS.Value, "#")
    lnSkobka = InStr(lnStar + 2, loCellS.Value, ")")
    lnField = lnStar
    Do While (Mid(loCellS.Value, lnField - 1, 1) <> "{") And (Mid(loCellS.Value, lnField - 1, 1) <> "<")
        lnField = lnField - 1
    Loop
    lcWhat = Mid(loCellS.Value, lnStar + 3, lnSkobka - lnStar - 3)
    lcMask = UCase(Mid(loCellS.Value, lnField, lnStar - lnField))
    i = 0
    For Each loCell In wsd.Range("DataFields")
        If UCase(Mid(loCell, 1, lnStar - lnField)) = lcMask Then
            i = i + 1
            laRepl(i, 2) = Mid(loCell, lnStar - lnField + 1)
            laRepl(i, 1) = Mid(loCellS.Value, 1, lnStar - 1) + laRepl(i, 2) + Mid(loCellS.Value, lnSkobka + 1)
        End If
    Next loCell
    For j = 1 To i - 1
        Call DubleRow(loCellS)
        loCellS.Offset(-1, 0).Select
        Set loCell = Selection.Cells(1, 1)
        Call ReplaceRowMask(loCell, laRepl(j, 1), lcWhat, laRepl(j, 2))
    Next j
    Call ReplaceRowMask(loCellS, laRepl(i, 1), lcWhat, laRepl(i, 2))
    Set loCell = Nothing
End Sub

Sub DubleRow(loCellS As Range)         ' Процедура дублирует строку (строки) данной ячейки
Dim loCellD As Range, i As Long
    loCellS.Select
    Selection.EntireRow.Insert
    Set loCellD = Selection.Cells(1, 1)
    Range(loCellS, loCellS.Offset(0, LastCell(loCellS).column)).Select
    Selection.Copy Destination:=loCellD
    Set loCellD = Nothing
End Sub

Sub ReplaceRowMask(loCellS As Range, lcValue As String, lcWhat As String, lcRepl As String)
    loCellS.Select          ' Процедура заменяет значение ячейки на lcValue и
    loCellS.Value = lcValue ' правее этой ячейки заменяет lcWhat на lcRepl
    Range(Selection, Selection.Offset(0, LastCell(Selection).column)).Replace What:=lcWhat, Replacement:=lcRepl
    Set loCellS = Nothing
End Sub

Sub AutoFitRow(rRange As Range)
Dim nWidth As Integer, nHeight As Integer, F As Font, rwRange As Range
    Set rRange = rRange.MergeArea
    nWidth = rRange.Columns.Width
    nHeight = rRange.Rows.RowHeight
    Set rwRange = wsd.Cells(rowsCount + 100, 1)
    rwRange.ColumnWidth = IIf((nWidth * rRange.Cells(1, 1).ColumnWidth / rRange.Cells(1, 1).Columns.Width) < 255, nWidth * rRange.Cells(1, 1).ColumnWidth / rRange.Cells(1, 1).Columns.Width, 255)
    rwRange.Value = rRange(1, 1).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
    Set rwRange = Nothing
End Sub

Function LastCell(r As Range) As Range
Dim rLast As Range
    Set rLast = r.Cells.SpecialCells(xlLastCell)
    If rLast.Cells(1, 1).Value = "" Then
        On Error Resume Next
        Set LastCell = r.Parent.Cells(r.Parent.Cells.Find("*", rLast, xlFormulas, , xlByRows, xlPrevious).Row, r.Parent.Cells.Find("*", rLast, xlFormulas, , xlByColumns, xlPrevious).Column)
        If Err.Number <> 0 Then Set LastCell = r.Parent.Cells(1, 1)
        On Error GoTo 0
    Else
        Set LastCell = rLast
    End If
    Set rLast = Nothing
End Function

Sub LoadNastr(lrNastr As Range)
Dim i As Long, lnNastrRow As Integer, lnNastrCol As Integer, qt As QueryTable, _
    n As Integer, lcName As String, lcText As String 'Титов
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    If Dir(dbPath + "c_nastr.dbf", vbNormal) <> "" Then
        lnNastrRow = lrNastr.Row
        lnNastrCol = lrNastr.Column
        
        lrNastr.Parent.Activate
        Set qt = lrNastr.Parent.QueryTables.Add("ODBC;" + _
            "Driver=" + GetODBCDriver() + ";" + _
            "UID=admin;SourceType=DBF;" + _
            "DefaultDir=" + dbPath + "\;" + _
            "DBQ=" + dbPath + "\;" + _
            "SourceDB=" + dbPath + "\;", lrNastr, "SELECT * FROM C_NASTR.DBF")
            
        qt.BackgroundQuery = False
        qt.FieldNames = True
        On Error GoTo Err1
        qt.Refresh
        On Error GoTo 0
        rowsCount = qt.ResultRange.Rows.Count
' Титов
        lrNastr.Parent.Parent.Names.Add Name:="NastrFields", _
         RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow+ 1)) + "C" + Trim(Str(lnNastrCol))+ ":R"+ Trim(Str(lnNastrRow+ rowsCount))+ "C" + Trim(Str(lnNastrCol))
        For i = 1 To rowsCount
            lcName = lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol)
            If lcName <> "" Then
                lrNastr.Parent.Parent.Names.Add Name:=lcName, _
                   RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow + i)) + "C" + Trim(Str(lnNastrCol + 1))
                If Mid(lcName, 1, 1) <> "c" Then
                    With lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol + 1)
                        If VarType(.Value) = vbString Then ' Титов
                            lcText = .Value
                        Else
                            lcText = .Text
                        End If
                        .FormulaLocal = IIf(Mid(lcText, 1, 1) = "=", " ", "") + lcText
                        '.FormulaLocal = IIf(Mid(.Text, 1, 1) = "=", " ", "") + .Text
                    End With
                End If
            End If
        Next i
        GoTo ExitProc
Err1:
        n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
        Er = -1
ExitProc:
    End If
    Set qt = Nothing
End Sub


Sub SetPageHeight()
Dim nZoom As Single, DX As Single, nPages As Integer
    If ActiveSheet.PageSetup.Zoom = False Then
        nPages = ActiveSheet.PageSetup.FitToPagesWide - 1
        If nPages > 0 Then
            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 If
End Sub

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
        nPageRow = ActiveSheet.HPageBreaks.count
        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
    End If
End Sub

Sub HideColumn()
    Dim c As Range
    Set c = Cells.Find("#?/?", LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            c.Interior.Pattern = xlPatternGray50
            c.Value = ""
            c.Select
            Selection.EntireColumn.Hidden = True
            Set c = Cells.FindNext(c)
        Loop While Not c Is Nothing
    End If
    Set c = Nothing
End Sub

Function GetStrParam(lcParam As String, ByVal lnParam As Integer, Optional lcSeparator As String = "#") As String
Dim nPos1 As Integer, nPos2 As Integer, i As Long
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = InStr(nPos1 + 1, lcParam, lcSeparator)
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = InStr(nPos1 + 1, lcParam, lcSeparator)
    nPos2 = IIf(nPos2 = 0, Len(lcParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = Mid(lcParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
End Function

Function StrReplace(cWhere As String, cWhat As String, cRepl As String) As String
Dim n As Integer
    n = 1
    Do
        n = InStr(n, cWhere, cWhat)
        If n > 0 Then
            cWhere = Mid(cWhere, 1, n - 1) + cRepl + Mid(cWhere, n + Len(cWhat))
            n = n + Len(cRepl)
        End If
    Loop While n <> 0
    StrReplace = cWhere
End Function

Function SaveSheet(filePath As String) As Integer
Dim ws As Object, fName As String
    Set ws = Application.ActiveWorkbook.ActiveSheet
    fName = filePath + ws.name
    ws.Copy
    ActiveWorkbook.SaveAs fileName:=fName + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    SaveSheet = 1
End Function

Function SaveBook(fileName As String) As Integer
    fileName = StrReplace(fileName, "$", "#")
    ActiveWorkbook.SaveAs fileName:=fileName + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    SaveBook = 1
End Function

Sub LoadTable(lr As Range, lcTable As String)
Dim qt As QueryTable, n As Integer
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    If Dir(dbPath + lcTable, vbNormal) <> "" Then
        lr.Parent.Activate
        Set qt = lr.Parent.QueryTables.Add("ODBC;" + _
            "Driver=" + GetODBCDriver() + ";" + _
            "UID=admin;SourceType=DBF;" + _
            "DefaultDir=" + dbPath + "\;" + _
            "DBQ=" + dbPath + "\;" + _
            "SourceDB=" + dbPath + "\;", lr, "SELECT * FROM " + lcTable)
        qt.BackgroundQuery = False
        qt.FieldNames = False
        On Error GoTo Err1
        qt.Refresh
        On Error GoTo 0
        rowsCount = qt.ResultRange.Rows.count
        columnsCount = qt.ResultRange.Columns.count
        If rowsCount <= 2 Then
            rowsCount = 0
            Do While Not IsEmptyRange(Range(Cells(rowsCount + lr.Row, 1), Cells(rowsCount + lr.Row, columnsCount)))
                rowsCount = rowsCount + 1
            Loop
        End If
        GoTo ExitProc
Err1:
        n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
        Er = -1
ExitProc:
    End If
    Set qt = Nothing
End Sub

Sub PrintFile(lcFile As String, lnMode As Integer, lcStr As String)
    If lnMode = 0 Then
        Open lcFile For Output As #1
    Else
        Open lcFile For Append As #1
    End If
    Print #1, lcStr
    Close #1
End Sub

Sub InitSheet()
Dim i As Long
    For i = 1 To 100
        tr(i).bottomB = False
        tr(i).topB = False
        tr(i).wrap = False
    Next i
End Sub

Sub InitTRows(r As Range)
Dim c As Range, rc As Integer, cc As Integer, i As Long, j As Integer, fval As String, _
    rs As Integer, cs As Integer, c_self As Integer, r_self As Integer, _
    rCount As Integer, cCount As Integer, cr1 As Integer, rr1 As Integer, k As Integer, _
    cValue As String
    
    rr1 = r(1).Row
    cr1 = r(1).column
    rCount = r.Rows.count
    cCount = r.Columns.count
    For i = rr1 To rr1 + cCount - 1
        col_width(i) = Int(Cells.Columns(i).ColumnWidth + 1)
    Next i
    For Each c In r
        rc = c.Row
        cc = c.column
        If c.Address(False, False, xlA1) = c.MergeArea(1).Address(False, False, xlA1) Then
            cValue = c.text
            ' Вычисление формул, начинающихся на ">>"
            If Mid(LTrim(cValue), 1, 2) = ">>" Then
                fval = LTrim(cValue)
                If Mid(fval, 3, 1) <> ">" Then
                    If Mid(fval, 3, 1) <> "=" Then

                        On Error Goto ErrAddr
                        c.FormulaLocal = "=" + Mid(fval, 3)
                        Goto NotErrAddr
ErrAddr:                MsgBox("Ошибка в формуле по адресу: " & c.Address(False, False))
                        c.Value = Mid(fval, 3)
NotErrAddr:             On Error GoTo 0

                    Else
                        c.FormulaLocal = "=" + Mid(fval, 4)
                    End If
                Else
                    c.FormulaLocal = "=" + Mid(fval, 4)
                    c.WrapText = True
                End If
            End If
            cs = c.MergeArea.Columns.count
            rs = c.MergeArea.Rows.count
            tr(rc).tc(cc).marged = (cs > 1 Or rs > 1)
            For i = 0 To rs - 1
                For j = 0 To cs - 1
                    tr(rc + i).tc(cc + j).colspan = IIf(j = 0, cs, 0)
                    tr(rc + i).tc(cc + j).rowspan = IIf(i = 0, rs, 0)
                Next j
            Next i
            tr(rc).tc(cc).wrap = c.WrapText Or c.ShrinkToFit
            tr(rc).tc(cc).h_align = c.HorizontalAlignment
            tr(rc).tc(cc).v_align = c.VerticalAlignment
            tr(rc).tc(cc).firstRow = rc
            tr(rc).tc(cc).firstCol = cc
            r_self = rc
            c_self = cc
            tr(rc).tc(cc).text = cValue
            tr(rc).tc(cc).textCol = cc
            If cValue Like "*[#]Н/Д*" Then
                c.Calculate
                If c.text = "#Н/Д" Then
                    col_width(cc) = 0
                End If
            End If
        Else
            tr(rc).tc(cc).marged = False
            r_self = c.MergeArea(1).Row
            c_self = c.MergeArea(1).column
            tr(rc).tc(cc).firstRow = r_self
            tr(rc).tc(cc).firstCol = c_self
            tr(rc).tc(cc).textCol = c_self
            tr(rc).tc(cc).wrap = tr(r_self).tc(c_self).wrap
            tr(rc).tc(cc).h_align = tr(r_self).tc(c_self).h_align
            tr(rc).tc(cc).v_align = tr(r_self).tc(c_self).v_align
            tr(rc).tc(cc).text = ""
        End If
        tr(rc).tc(cc).leftB = ((c.Borders(xlEdgeLeft).LineStyle <> xlNone) And c_self = cc)
        tr(rc).tc(cc).rightB = ((c.Borders(xlEdgeRight).LineStyle <> xlNone) And cc = (c_self + tr(rc).tc(c_self).colspan - 1))
        tr(rc).tc(cc).topB = ((c.Borders(xlEdgeTop).LineStyle <> xlNone) And r_self = rc)
        tr(rc).tc(cc).bottomB = ((c.Borders(xlEdgeBottom).LineStyle <> xlNone) And rc = (r_self + tr(r_self).tc(cc).rowspan - 1))
    Next c
    For j = cr1 To cr1 + cCount - 1
        tr(0).tc(j).bottomB = False
        tr(0).tc(j).leftB = False
        tr(0).tc(j).rightB = False
    Next j
    
    For i = rr1 To rr1 + rCount - 1
        For j = cr1 + 1 To cr1 + cCount - 1
        
            If tr(i).tc(j).colspan = 1 And tr(i).tc(j).rowspan = 1 And tr(i).tc(j).text = "" Then
                If Not tr(i).tc(tr(i).tc(j - 1).firstCol).wrap And _
                   tr(i).tc(tr(i).tc(j - 1).firstCol).text <> "" And _
                   (tr(i).tc(tr(i).tc(j - 1).firstCol).h_align = xlLeft Or _
                        tr(i).tc(tr(i).tc(j - 1).firstCol).h_align = xlCenter Or _
                        tr(i).tc(tr(i).tc(j - 1).firstCol).h_align = xlGeneral) And _
                   Not tr(i).tc(tr(i).tc(j - 1).firstCol).marged Then
                    If Not tr(i).tc(j - 1).rightB And _
                       Not tr(i).tc(j).leftB And _
                       tr(i).tc(j - 1).topB = tr(i).tc(j).topB And _
                       tr(i).tc(j - 1).bottomB = tr(i).tc(j).bottomB Then
                        tr(i).tc(tr(i).tc(j - 1).firstCol).colspan = tr(i).tc(tr(i).tc(j - 1).firstCol).colspan + 1
                        tr(i).tc(j).colspan = 0
                        tr(i).tc(j).firstCol = tr(i).tc(j - 1).firstCol
                    End If
                End If
            End If
        
        Next j
        For j = cr1 + cCount - 2 To cr1 Step -1
            
            If tr(i).tc(j).colspan = 1 And tr(i).tc(j).rowspan = 1 And tr(i).tc(j).text = "" Then
                If Not tr(i).tc(j + 1).wrap And _
                   tr(i).tc(j + 1).text <> "" And _
                   (tr(i).tc(j + 1).h_align = xlRight Or _
                        tr(i).tc(j + 1).h_align = xlCenter) And _
                   Not tr(i).tc(j + 1).marged Then
                    If Not tr(i).tc(j).rightB And _
                       Not tr(i).tc(j + 1).leftB And _
                       tr(i).tc(j + 1).topB = tr(i).tc(j).topB And _
                       tr(i).tc(j + 1).bottomB = tr(i).tc(j).bottomB Then
                        tr(i).tc(j).textCol = tr(i).tc(j + 1).textCol
                        tr(i).tc(j).text = tr(i).tc(j + 1).text
                        tr(i).tc(j).wrap = False
                        tr(i).tc(j).h_align = xlRight
                        tr(i).tc(j).colspan = tr(i).tc(j + 1).colspan + 1
                        tr(i).tc(j + 1).text = ""
                        tr(i).tc(j + 1).colspan = 0
                        tr(i).tc(j + 1).firstCol = j
                    End If
                End If
            End If
        
        Next j
    Next i
            
    For i = rr1 To rr1 + rCount - 1
        For j = cr1 To cr1 + cCount - 1
            tr(i).tc(j).twitdh = 0
            If tr(i).tc(j).colspan > 0 Then
                For k = 1 To tr(i).tc(j).colspan
                    tr(i).tc(j).twitdh = tr(i).tc(j).twitdh + col_width(j + k - 1) + _
                        IIf(k > 1 And col_width(j + k - 1) > 0, 1, 0)
                Next k
            End If
        Next j
    Next i
End Sub

Function GetTXTLine(curRow As Long, startCol As Integer, colCount As Integer, Optional bLast As Boolean = False) As String
Dim st As String, i As Long, j As Integer, k As Integer, rf As Integer, _
    j0 As Integer, cf As Integer, _
    bLeft As Boolean, bTop As Boolean, bRight As Boolean, bBot As Boolean, _
    nch As Variant
    
    bRight = False
    st = ""
    j0 = startCol - 1
    For j = startCol To startCol + colCount
        If col_width(j) > 0 Or j = startCol + colCount Then
            bLeft = bRight
            If j < (startCol + colCount) Then
                bTop = ((j > startCol And tr(0).tc(j0).rightB) Or tr(0).tc(j).leftB)
                bBot = (((j > startCol And tr(curRow).tc(j0).rightB) Or tr(curRow).tc(j).leftB) And Not bLast)
                bRight = (tr(0).tc(j).bottomB Or (tr(curRow).tc(j).topB And Not bLast))
            Else
                bTop = tr(0).tc(j0).rightB
                bBot = (tr(curRow).tc(j0).rightB And Not bLast)
                bRight = False
            End If
            tr(0).tc(j).bottomB = tr(curRow).tc(j).bottomB
            tr(0).tc(j).leftB = tr(curRow).tc(j).leftB
            tr(0).tc(j0).rightB = tr(curRow).tc(j0).rightB

            If lcTxtCode<>"1251" Then
                nch = Switch( _
                    Not bLeft And Not bTop And bRight And bBot, 218, _
                    bLeft And Not bTop And bRight And bBot, 194, _
                    bLeft And Not bTop And Not bRight And bBot, 191, _
                    Not bLeft And bTop And bRight And bBot, 195, _
                    bLeft And bTop And bRight And bBot, 197, _
                    bLeft And bTop And Not bRight And bBot, 180, _
                    Not bLeft And bTop And bRight And Not bBot, 192, _
                    bLeft And bTop And bRight And Not bBot, 193, _
                    bLeft And bTop And Not bRight And Not bBot, 217, _
                    Not bLeft And bTop And Not bRight And bBot, 179, _
                    bLeft And Not bTop And bRight And Not bBot, 196)
            Else
                nch = Switch( _
                    Not bLeft And Not bTop And bRight And bBot, 114, _
                    bLeft And Not bTop And bRight And bBot, 84, _
                    bLeft And Not bTop And Not bRight And bBot, 92, _
                    Not bLeft And bTop And bRight And bBot, 62, _
                    bLeft And bTop And bRight And bBot, 43, _
                    bLeft And bTop And Not bRight And bBot, 60, _
                    Not bLeft And bTop And bRight And Not bBot, 76, _
                    bLeft And bTop And bRight And Not bBot, 94, _
                    bLeft And bTop And Not bRight And Not bBot, 47, _
                    Not bLeft And bTop And Not bRight And bBot, 166, _
                    bLeft And Not bTop And bRight And Not bBot, 45)
            End If

            st = st + Chr(IIf(IsNull(nch), 32, nch))
            If j < (startCol + colCount) Then
                rf = tr(curRow).tc(j).firstRow
                cf = tr(curRow).tc(j).firstCol
                If rf < curRow Then
                    If tr(curRow).tc(cf).wrap And (tr(rf).tc(cf).curLN <= tr(rf).tc(cf).countLN) Then
                        st = st + GetStrParam(tr(rf).tc(cf).text, tr(rf).tc(cf).curLN, Chr(10))
                        tr(rf).tc(cf).curLN = tr(rf).tc(cf).curLN + 1
                    Else
                        st = st + String(tr(rf).tc(cf).twitdh, " ")
                    End If
                    For k = j + 1 To j + tr(curRow).tc(cf).colspan - 1
                        tr(0).tc(k).bottomB = tr(0).tc(j).bottomB
                    Next k
                    j = j + tr(curRow).tc(cf).colspan - 1
                Else
                    st = st + String(col_width(j), Chr(IIf(bRight, IIf(lcTxtCode<>"1251", 196, 45), 32)))
                End If
            End If
            j0 = j
        End If
    Next j
    GetTXTLine = st
End Function

Function GetTXTLastLine(r As Range) As String
    GetTXTLastLine = GetTXTLine(0, r(1).column, r.Columns.count, True)
End Function

Function GetAligmentString(st As String, tWidth As Integer, nAlign As Integer) As String
Dim n2 As Integer, L As Integer
    If Len(st) > tWidth Then
        st = Mid(st, 1, tWidth)
    End If
    L = Len(st)
    If nAlign = xlRight Then
        GetAligmentString = String(tWidth - L, " ") & st
    Else
        If nAlign = xlCenter Then
            n2 = Int((tWidth - L) / 2)
            GetAligmentString = String(n2, " ") & st & String(tWidth - L - n2, " ")
        Else
            GetAligmentString = st & String(tWidth - L, " ")
        End If
    End If

End Function

Function GetWrapTextHeight(tWidth As Integer, ByRef st As String, Optional nAlign As Integer = xlLeft) As Integer
Dim n As Integer, i As Long, cnt As Integer, nch As Integer, _
    st0 As String, st1 As String, st2 As String, ch As String, st_res As String
       
    st_res = ""
    st = st & " "
    cnt = Len(st)
    i = 1
    n = 1           ' число строк
    st0 = ""
    ch = Mid(st, i, 1)
    nch = Asc(ch)   ' пропускаем переводы строк
    While i < cnt
        While i < cnt And nch = 10
            st_res = st_res & GetAligmentString(st0, tWidth, nAlign) & ch
            st0 = ""
            n = n + 1
            i = i + 1
            ch = Mid(st, i, 1)
            nch = Asc(ch)
        Wend
        st1 = ""        ' считаем пробелы
        st2 = ""
        While i < cnt And nch = 32
            i = i + 1
            st1 = st1 & ch
            ch = Mid(st, i, 1)
            nch = Asc(ch)
        Wend
        If i < cnt And nch <> 10 Then
            st2 = ""    ' считаем слово
            While i < cnt And nch <> 10 And nch <> 32 And ch <> "-"
                i = i + 1
                st2 = st2 & ch
                ch = Mid(st, i, 1)
                nch = Asc(ch)
            Wend
            If ch = "-" Then
                st2 = st2 + ch
                i = i + 1
                ch = Mid(st, i, 1)
                nch = Asc(ch)
            End If
            If Len(st0 & st1 & st2) > tWidth Then ' если с новым словом не умещается
                If st0 & st1 <> "" Then
                    st_res = st_res & GetAligmentString(st0, tWidth, nAlign) & Chr(10)
                    n = n + 1
                End If
                st1 = ""
                st0 = ""
                While Len(st2) > tWidth        ' пока само слово не имещается
                    st_res = st_res & Mid(st2, 1, tWidth) & Chr(10)
                    st2 = Mid(st2, tWidth + 1)
                    n = n + 1
                Wend
            End If
        End If
        st0 = st0 & st1 & st2
    Wend
    st_res = st_res & GetAligmentString(st0, tWidth, nAlign)
    st = st_res
    GetWrapTextHeight = n
End Function

Sub InitTextData(r As Range)
Dim cValue As String, c As Range, rc As Integer, cc As Integer
    For rc = r(1).Row To r(1).Row + r.Rows.count - 1
        For cc = r(1).column To r(1).column + r.Columns.count - 1
            If tr(rc).tc(cc).rowspan > 0 And tr(rc).tc(cc).colspan > 0 And col_width(cc) > 0 Then
                If tr(rc).tc(cc).text <> "" Then
                    cValue = Cells(rc, tr(rc).tc(cc).textCol).text
                    If Len(cValue)=1024 Then
                        cValue = Cells(rc, tr(rc).tc(cc).textCol).Value
                    End If
                    cValue = StrReplace(cValue, Chr(13), "")
                    If lcTxtCode <> "1251" Then
                        cValue = ConvertToOEM(cValue)
                    End If
                Else
                    cValue = ""
                End If
                    If tr(rc).tc(cc).wrap Then
                        tr(rc).tc(cc).countLN = GetWrapTextHeight(tr(rc).tc(cc).twitdh, cValue, tr(rc).tc(cc).h_align)
                        tr(rc).tc(cc).curLN = 1
                    Else
                        cValue = Mid(StrReplace(cValue, Chr(10), " "), 1, tr(rc).tc(cc).twitdh)
                        If Len(cValue) < tr(rc).tc(cc).twitdh Then
                            cValue = GetAligmentString(cValue, tr(rc).tc(cc).twitdh, tr(rc).tc(cc).h_align)
                        End If
                    End If
                    tr(rc).tc(cc).text = cValue
            End If
         Next cc
     Next rc

End Sub

Function GetTextBody(r As Range) As String
Dim st As String, st0 As String, i As Long, j As Integer, _
    rCount As Integer, cCount As Integer, cr1 As Integer, rr1 As Integer, rf As Integer, _
    cValue As String, chLN As String, stl As String, cf As Integer, j0 As Integer, _
    bRepeat As Boolean, nRepeat As Integer
    
    chLN = Chr(13) + Chr(10)
    st = ""
    rr1 = r(1).Row
    cr1 = r(1).column
    rCount = r.Rows.count
    cCount = r.Columns.count
    For i = rr1 To rr1 + rCount - 1
        stl = GetTXTLine(i, cr1, cCount)
        If Trim(stl) <> "" Then
            st = st + stl + chLN
        End If
        nRepeat = 0
        bRepeat = True
        While bRepeat
            st0 = ""
            bRepeat = False
            j0 = cr1 - 1
            For j = cr1 To cr1 + cCount - 1
                If col_width(j) > 0 Then
                    rf = tr(i).tc(j).firstRow
                    cf = tr(i).tc(j).firstCol
                    st0 = st0 + IIf(((j > cr1) And tr(i).tc(j0).rightB) Or tr(i).tc(j).leftB, IIf(lcTxtCode<>"1251", Chr(179), Chr(166)), " ")
                    If tr(rf).tc(cf).wrap Then
                        If tr(rf).tc(cf).curLN <= tr(rf).tc(cf).countLN Then
                            st0 = st0 + GetStrParam(tr(rf).tc(cf).text, tr(rf).tc(cf).curLN, Chr(10))
                            tr(rf).tc(cf).curLN = tr(rf).tc(cf).curLN + 1
                            bRepeat = bRepeat Or _
                             (tr(rf).tc(cf).curLN <= tr(rf).tc(cf).countLN) And (i = rf + tr(rf).tc(cf).rowspan - 1)
                        Else
                            st0 = st0 + String(tr(rf).tc(cf).twitdh, " ")
                        End If
                    Else
                        st0 = st0 + IIf(nRepeat = 0 And tr(i).tc(cf).text <> "", tr(i).tc(cf).text, String(tr(i).tc(cf).twitdh, " "))
                    End If
                    j0 = j
                    j = cf + tr(i).tc(cf).colspan - 1
                End If
            Next j
            st0 = st0 + IIf(tr(i).tc(cr1 + cCount - 1).rightB, IIf(lcTxtCode<>"1251", Chr(179), Chr(166)), " ")
            st = st + st0 + IIf(bRepeat Or (i < (rr1 + rCount - 1)), chLN, "")
            nRepeat = nRepeat + 1
        Wend
    Next i
    GetTextBody = st
End Function

Function ConvertToOEM(ByVal s As String) As String
  Dim TmpStr As String, i As Long, char As String, char2 As String
  char2 = ""
  TmpStr = ""
  For i = 1 To Len(s)
    char = Mid(s, i, 1)
    Select Case char
      Case "а" To "п", "А" To "Я"
        char2 = Chr(Asc(char) - 64)
      Case "р" To "я"
        char2 = Chr(Asc(char) - 16)
      Case "ё"
        char2 = Chr(241)
      Case "Ё"
        char2 = Chr(240)
      Case "№"
        char2 = "N"
      Case Else
        char2 = char
    End Select
    TmpStr = TmpStr + char2
  Next i
  ConvertToOEM = TmpStr
End Function
