Attribute VB_Name = "repmaker_h"
'
' 22.09.2006 Учет настройки "Черно-белая печать"
' 07.07.2004 Возможность печатать более 50 групп, получать значение предыдущей группы
' 22.03.2004 выравнивание по значению -> выравнивание по нижнему краю
' 11.03.2004 Добавлен скроллинг на ячейку [a1]
' 10.03.2004 Для ячеек начинающихся на >>> ставится свойство переносить по словам принудительно
' 10.03.2004 Подправления Титова
' 17.02.2004 Цифровые данные остаются цифровыми
' 10.02.2003 В ячейке [K1] можно указать поле, по которому, будут обзываться листы
' 27.06.2003 Исправлен глюк с пробелами
' 02.04.2003 исправлена печать колонтитулов с переносом строк
' 27.03.2003 добавлено автосохранение
' 21.03.2003 подправлено: размер бумаги, ориаентация страниц
' 09.12.2002 сортировка в совокупности с группами
' 05.12.2002 заполнение таблицы листа в htm через c_table.htm
'
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, SheetsNames(255) As String, _
       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, _
       cAutoSaveName As String, cAutoSavePath As String, _
       lcTableFile As String, _
       wsoRange As Range, _
       lcSheetOptions As String, lcStyleOptions As String, _
       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
'добавлено 19.07.2005
Public LFooter As String, CFooter As String, RFooter As String, bCalcFooter As Boolean

'добавлено 22.09.2006
Public lbBlackAndWhite As Boolean

       
Public Type WebCell
        colspan As String
        rowspan As String
        value As String
        column As Integer
        style As String
End Type
Public Type WebStyle
        text_align As String
        vertical_align As String
        mso_number_format As String
        white_space As String
        mso_text_control As String
        border_left As String
        border_right As String
        border_top As String
        border_bottom As String
        font_size As String
        font_weight As String
        font_family As String
        font_style As String
        text_decoration As String
        style As String
        mso_style_parent As String
        background As String
        color As String
        mso_pattern As String
End Type
Public Type WebStyles
    count As Integer
    wc() As WebStyle
End Type
Public Type WebCells
    count As Long
    row_height As Double
    wc() As WebCell
End Type
Public Type WebSheet
    name As String
    Zoom As String
    FitToPage As String
    FitWidth As String
    FitHeight As String
    PaperSizeIndex As String
    DisplayGridLines As String
    DisplayZeros As String
    TitleRows As String
    TitleColumns As String
    FreezePanes As String
    HB(5000) As Long
    HBCount As Integer
End Type
Public Type DataField
    column As Integer
    name As String
End Type
Public lcWebFile As String, lcStyleFile As String, lcWebDir As String, _
    lcTabStripFile As String, lcFileList As String, lcWorkBook As String, _
    wcs(65536) As WebCells, style As WebStyles, _
    ColWidth(256) As Double, _
    WebSheets(256) As WebSheet, WebSheetsCount As Integer, _
    st_col_width As String, st_table As String, _
    st_begin_sheet As String, st_end_sheet As String, st_main As String, _
    st_table_declare As String, st_style As String, st_filelist As String, _
    lcWebSheetFile As String, lcWebSheetName As String, _
    lbFreeze As Boolean, _
    st_tabstrip As String, DataFields(255) As DataField
       
Sub MakeReport()
Dim ws As Object, lcString As String, lnPos As Long, 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, _
    lcStringOrder As String, nRet As Integer

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

    DataStartRow = 10
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    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
    dbSelect = Trim(ThisWorkbook.Sheets(1).[d2].value)
    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

    cAutoSavePath = ThisWorkbook.Sheets(1).[n2].value
    If cAutoSavePath <> "" Then
        cAutoSavePath = cAutoSavePath + IIf(Mid(cAutoSavePath, Len(cAutoSavePath), 1) = "\", "", "\")
    End If
    cAutoSaveName = ThisWorkbook.Sheets(1).[O2].value
    lbBlackAndWhite = ThisWorkbook.Sheets(1).[P2].value

    lcAddParam = Trim(ThisWorkbook.Sheets(1).[f2].value)
    lcAddModule = GetStrParam(lcAddParam, 3)
    If lcAddModule <> "" Then
        nRet = AddModule(Application.ThisWorkbook, 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 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
    
'html -------------------------------------------------------
    lcWorkBook = ActiveWorkbook.name
    If InStr(lcWorkBook, ".xl") > 0 Then lcWorkBook = Mid(lcWorkBook, 1, InStr(lcWorkBook, ".xl") - 1)

    If IsNumeric(Mid(lcWorkBook, Len(lcWorkBook), 1)) Then
        lcWorkBook = Mid(lcWorkBook, 1, Len(lcWorkBook) - 1)
    End If
    i = 1
    Do While Dir(dbPath + lcWorkBook + Trim(Str(i)) + ".files\", vbDirectory) <> ""
        i = i + 1
    Loop
    lcWorkBook = lcWorkBook + Trim(Str(i))

    lcWebFile = dbPath + lcWorkBook + ".htm"
    lcWebDir = lcWorkBook + ".files\"
    On Error GoTo Err_MkDir:
    If Dir(dbPath + lcWebDir, vbDirectory) <> "" Then
        Kill (dbPath + lcWebDir + "*.*")
'        RmDir (dbPath + lcWebDir)
    Else
        MkDir (dbPath + lcWebDir)
    End If
Err_MkDir:
    On Error GoTo 0
    lcStyleFile = dbPath + lcWebDir + "stylesheet.css"
    lcTabStripFile = dbPath + lcWebDir + "tabstrip.htm"
    lcFileList = dbPath + lcWebDir + "filelist.xml"
    WebSheetsCount = 0
    Call InitStyle
'/html ------------------------------------------------------

    Set wso = Application.ActiveWorkbook.ActiveSheet



    ' Добавляем модуль FUNCTIONS.BAS
    nRet = AddModule(Application.ActiveWorkbook, 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)
            lcStringOrder = wso.[f1]
            lcString = ""

            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
                If c.Offset(i - 1, 3).value = "" Or c.Offset(i - 1, 3).value = 1 Then
                    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
                End If
            Next i
            If lcStringOrder <> "" Then
                lcString = lcString + IIf(lcString = "", "", ", ") + lcStringOrder
            End If
            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

    lcString = wso.[K1]
    If SheetFieldName = "" And lcString <> "" Then
        SheetFieldName = lcString
    End If

'    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
        If SheetFieldName <> "" Then
            lcString = SheetFieldName + ", " + lcString
        End If
        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
                
'html -------------------------------------------------------
                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)
                    End If
                    wso.Activate

'Изменение формирования имен листов для пакетной выгрузки
                    lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                    If lcWebSheetName Like "[#]*[#]*[#]*" Then
                        SheetsNames(WebSheetsCount) = lcWebSheetName
                        lcWebSheetName = wso.name + "_" + Trim(Str(WebSheetsCount))
                    End If

                End If
                lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                WebSheets(WebSheetsCount).name = lcWebSheetName
                lcWebSheetFile = dbPath + lcWebDir + "Sheet_" + Trim(Str(WebSheetsCount)) + ".htm"
                lcTableFile = dbPath + "c_table.htm"
'/html ------------------------------------------------------
                
                wso.Activate

'добавлено 19.07.2005
                On Error GoTo PErr1
                wso.Cells(gEndPosF(1) + 1, 10) = wso.PageSetup.LeftFooter
                wso.Cells(gEndPosF(1) + 1, 11) = wso.PageSetup.CenterFooter
                wso.Cells(gEndPosF(1) + 1, 12) = wso.PageSetup.RightFooter
PErr1:          On Error GoTo 0
                
                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
                
'html -------------------------------------------------------
                Call AddStyle(wsoRange)
                
'добавлено 19.07.2005
                LFooter = wso.Cells(gEndPosF(1) + 1, 10).FormulaLocal
                CFooter = wso.Cells(gEndPosF(1) + 1, 11).FormulaLocal
                RFooter = wso.Cells(gEndPosF(1) + 1, 12).FormulaLocal
                If LFooter Like "=*" Or CFooter Like "=*" Or RFooter Like "=*" Then
                    bCalcFooter = True
                Else
                    bCalcFooter = False
                End If



                st_begin_sheet = GetWebSheetBegin(wsoRange, _
                    IIf(nxlLeftHeader <> "", "&8&Л" & nxlLeftHeader, "") + _
                    IIf(nxlCenterHeader <> "", "&8&Ц" & nxlCenterHeader, "") + _
                    IIf(nxlRightHeader <> "", "&8&П" & nxlRightHeader, ""))

                Call PrintFile(lcTableFile, 0, "")
                st_table = ""
                curPosR = 1
                WebSheets(WebSheetsCount).HBCount = 0
'                Application.ActiveWindow.DisplayZeros = True
'/html ------------------------------------------------------

                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)
                
'html -------------------------------------------------------
                st_end_sheet = GetWebSheetEnd()
                st_table_declare = GetWebTableDeclare(wsoRange)
                st_col_width = GetWebColDeclare(wsoRange)
                Call PrintFile(lcWebSheetFile, 0, st_begin_sheet)
                Call PrintFile(lcWebSheetFile, 1, st_table_declare)
                Call PrintFile(lcWebSheetFile, 1, st_col_width)
                Call AppendFileFormFile(lcWebSheetFile, lcTableFile)
                Call PrintFile(lcWebSheetFile, 1, st_col_width)
                Call PrintFile(lcWebSheetFile, 1, st_end_sheet)
'/html ------------------------------------------------------
                
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Формирование листов отчета в html")
                End If

                wso.Delete
            End If
            lnRepSheet = lnRepSheet + 1
        Wend
        
'html -------------------------------------------------------
        st_style = GetWebStylesDeclare()
        Call PrintFile(lcStyleFile, 0, st_style)
        st_tabstrip = GetWebTabStrip()
        Call PrintFile(lcTabStripFile, 0, st_tabstrip)
        st_filelist = GetWebFileList()
        Call PrintFile(lcFileList, 0, st_filelist)
        st_main = GetWebMain()
        Call PrintFile(lcWebFile, 0, st_main)
'/html ------------------------------------------------------
        
        If lbStat Then
            dTime2 = Time()
            nTimeDiff = DateDiff("s", dTime1, dTime2)
            dTime1 = dTime2
            Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Формирование основного файла html")
        End If
        
        If Val(Application.Version) >= 9 Then
            Application.Workbooks.Open (lcWebFile)
            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Открытие html отчета в Excel")
                dTime1 = dTime2
            End If
            
            Application.DisplayAlerts = False


            ' Добавляем дополнительные модули (ячейка H1)
            i = 1
            While GetStrParam(lcAddModuleFunc2, i) <> ""
                lcString = VBA.Trim(GetStrParam(lcAddModuleFunc2, i))
                If StrConv(lcString, vbUpperCase) <> "REPMAKER.BAS" Then
                    nRet = AddModule(Application.ThisWorkbook, repPath + "MODULES\", lcString)
                End If
                i = i + 1
            Wend
            ' Выполняем дополнительные функции (ячейка I1)
            i = 1
            While GetStrParam(lcAddModuleFuncArg2, i) <> ""
                lcString = GetStrParam(lcAddModuleFuncArg2, i + 1)
                j = Len(lcString) - Len(StrReplace(lcString, ",", ""))
                lcString = StrReplace(lcString, ",", "#")
                Select Case j
                Case 4
                    j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3), GetStrParam(lcString, 4), GetStrParam(lcString, 5))
                Case 3
                    j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3), GetStrParam(lcString, 4))
                Case 2
                    j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2), GetStrParam(lcString, 3))
                Case 1
                    j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcString, 1), GetStrParam(lcString, 2))
                Case Else
                    If lcString <> "" Then
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), lcString)
                    Else
                        j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i))
                    End If
                End Select
                i = i + 2
            Wend
            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                dTime1 = dTime2
                Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Дополнительные действия")
            End If
            
            
            
            ' Создаем свою панель инструментов
            Call InitCBR
            lnPos = 1
            Application.StatusBar = "Подготовка листов (0%)"
            dTimeAllPage = Time()

            If lcAddModuleFunc = "SaveSheet" Then
                ActiveWorkbook.SaveAs fileName:=StrReplace(lcWebFile, ".htm", ".xls"), FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                ActiveWorkbook.Close SaveChanges:=True
                Application.Workbooks.Open (StrReplace(lcWebFile, ".htm", ".xls"))
            End If
    
            For Each ws In Application.ActiveWorkbook.Worksheets
                ws.Activate
                dTimePage = Time()

                Application.StatusBar = "Подготовка листов (" & Int(lnPos * 100 / Application.ActiveWorkbook.Worksheets.count) & "%)"
                lnPos = lnPos + 1

  
                If lcAddModuleFunc <> "" Then
                    j = Run(lcAddModuleFunc, lcAddModuleFuncArg)
                End If
                i = 6
                While GetStrParam(lcAddParam, i) <> ""
                    j = Run(GetStrParam(lcAddParam, i), GetStrParam(lcAddParam, i + 1))
                    i = i + 2
                Wend
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Выполнение дополнительных функций дополнительных модулей")
                    Call PrintFile(lcLogFile, 1, "    Всего на подготовку листа " & ws.name & ": " & DateDiff("s", dTimePage, dTime2) & " сек")
                End If
            Next ws
        Else
            Shell ("explorer """ + lcWebFile + """")
            If lbStat Then
                dTime2 = Time()
                nTimeDiff = DateDiff("s", dTime1, dTime2)
                Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Открытие html отчета в Explorer")
                dTime1 = dTime2
            End If
        End If
    End If

    Application.DisplayAlerts = False
    wsd.Parent.Close

    If lbStat Then
        dTime2 = Time()
        Call PrintFile(lcLogFile, 1, "  Всего подготовка листов: " & DateDiff("s", dTimeAllPage, dTime2) & " сек")
        dTime1 = dTime2
    End If

    If cAutoSaveName <> "" And Val(Application.Version) >= 9 Then
        If cAutoSavePath = "" Then
            cAutoSavePath = dbPath
        End If
        On Error Resume Next
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs fileName:=cAutoSavePath + cAutoSaveName, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        Application.DisplayAlerts = True
        On Error GoTo 0
        If lbStat Then
            dTime2 = Time()
            nTimeDiff = DateDiff("s", dTime1, dTime2)
            dTime1 = dTime2
            Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Автосохранение в каталог " & cAutoSavePath)
        End If
    End If

    If lbStat Then
        Call PrintFile(lcLogFile, 1, "Всего на создание отчета: " & DateDiff("s", dTimeBegin, dTime2) & " сек")
    End If

    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Visible = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.ActiveWorkbook.Saved = True
    Application.ThisWorkbook.Windows(1).Visible = False
    Application.ThisWorkbook.Saved = True

    If (lnBits And 2) > 0 Then
        Application.ActiveWorkbook.Close
        Application.ThisWorkbook.Close
    End If
End Sub

Sub AutoFitRows()
Dim Com As Comment, ws As Object, rRange As Range
    Application.StatusBar = "Подбор высоты строк..."
    For Each ws In Application.ActiveWorkbook.Worksheets

        Set rRange = Nothing
        If ws.Comments.count > 0 Then
            ws.Activate
            For Each Com In ws.Comments
                If Not Com.Parent.MergeCells Then
                    If Com.Text = "Eval" Then
                       Com.Parent.FormulaLocal = "=" + Mid(Com.Parent.value, 5)
                    Else
                       If rRange Is Nothing Then Set rRange = Com.Parent.EntireRow Else Set rRange = Union(rRange, Com.Parent.EntireRow)
                    End If
                    Com.Delete
                End If
            Next Com
        End If
        If Not rRange Is Nothing Then rRange.EntireRow.AutoFit

        If ws.Comments.count > 0 Then
            ws.Activate
            For Each Com In ws.Comments
                If Com.Text = "Eval" Then
                    Com.Parent.FormulaLocal = "=" + Mid(Com.Parent.value, 5)
                Else
                    Call AutoFitRow(Com.Parent)
                End If
                Com.Delete
            Next Com
        End If
    Next ws
    Set rRange = Nothing
End Sub

Sub MinimizeWindow()
    Application.WindowState = xlMinimized
End Sub

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

Sub InitCBR()
    ' Удаляем старую панель
    Call DeleteCBR("Печать")
    ' Добавляем новую панель
    Application.CommandBars.Add(name:="Печать", Position:=msoBarTop, Temporary:=True).Visible = True
    Application.CommandBars("Печать").Controls.Add Type:=msoControlButton, Id:= _
        109, Before:=1
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, Id:= _
        2521, Before:=2)
        .Caption = "Печать текущего документа"
    End With
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, _
        Before:=3)
        .FaceId = 160
        .style = msoButtonIcon
        .Caption = "Печать всех документов"
        .OnAction = "PrintAll"
    End With
End Sub

Sub DeleteCBR(cbrname As String)
Dim Found As Boolean, cbar As Object
    Found = False
    For Each cbar In Application.CommandBars
        If cbar.name = cbrname Then Found = True
    Next
    If Found Then Application.CommandBars(cbrname).Delete
    Set cbar = Nothing
End Sub

Sub PrintAll()
Dim ws As Object
    For Each ws In Application.ActiveWorkbook.Worksheets
        ws.PrintOut
    Next ws
    Set ws = Nothing
End Sub

Sub LoadData()
Dim startRange As Range, qt As QueryTable, odbcDriver As String, odbcstr As String, n As Long
    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:
    wsd.[f1] = dbSelect
    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   ' Имя поля

On Error Resume Next
        
        wsd.Parent.Names.Add name:=fName, RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 3)) + "C" + Trim(Str(0 + i))

On Error GoTo 0

        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), "")




        ' Создание нового листа убрано условие: Or curPosR > 32000
        If (groupProp(curGr, 2) And Not nxlPages) Then
            If groupProp(curGr, 7) Then
                groupProp(curGr, 7) = False
            Else
                
'html -------------------------------------------------------
                If SheetFieldColumn > 0 Then

                    cNewSheet = StrReplace(wsd.Cells(curPosD, SheetFieldColumn), " ", "")
'Изменение формирования имен листов для пакетной выгрузки
                    If cNewSheet Like "[#]*[#]*[#]*" Then
                        SheetsNames(WebSheetsCount + 1) = cNewSheet
                        cNewSheet = ""
                    End If

                Else
                    cNewSheet = ""
                End If
                If cNewSheet <> WebSheets(WebSheetsCount).name Then

'добавлено 19.07.2005
                    If bCalcFooter Then
                        On Error GoTo PErr2
                        If LFooter <> "" Then
                            wso.Cells(gEndPosF(curGr) + 1, 10).FormulaLocal = LFooter
                            wso.PageSetup.LeftFooter = wso.Cells(gEndPosF(curGr) + 1, 10).value
                        End If
                        If CFooter <> "" Then
                            wso.Cells(gEndPosF(curGr) + 1, 11).FormulaLocal = CFooter
                            wso.PageSetup.CenterFooter = wso.Cells(gEndPosF(curGr) + 1, 11).value
                        End If
                        If RFooter <> "" Then
                            wso.Cells(gEndPosF(curGr) + 1, 12).FormulaLocal = RFooter
                            wso.PageSetup.RightFooter = wso.Cells(gEndPosF(curGr) + 1, 12).value
                        End If
PErr2:                  On Error GoTo 0
                        st_begin_sheet = GetWebSheetBegin(wsoRange, _
                            IIf(nxlLeftHeader <> "", "&8&Л" & nxlLeftHeader, "") + _
                            IIf(nxlCenterHeader <> "", "&8&Ц" & nxlCenterHeader, "") + _
                            IIf(nxlRightHeader <> "", "&8&П" & nxlRightHeader, ""))
                    End If
                        

                    st_end_sheet = GetWebSheetEnd()
                    st_table_declare = GetWebTableDeclare(wsoRange)
                    st_col_width = GetWebColDeclare(wsoRange)
                    Call PrintFile(lcWebSheetFile, 0, st_begin_sheet)
                    Call PrintFile(lcWebSheetFile, 1, st_table_declare)
                    Call PrintFile(lcWebSheetFile, 1, st_col_width)
                    Call AppendFileFormFile(lcWebSheetFile, lcTableFile)
                    Call PrintFile(lcWebSheetFile, 1, st_col_width)
                    Call PrintFile(lcWebSheetFile, 1, st_end_sheet)
                
                    WebSheetsCount = WebSheetsCount + 1
                    lcWebSheetName = wso.name + "_" + Trim(Str(WebSheetsCount))
                    If SheetFieldColumn > 0 And cNewSheet <> "" Then
                        lcWebSheetName = cNewSheet
                    End If
                    lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                    WebSheets(WebSheetsCount).name = lcWebSheetName

                    lcWebSheetFile = dbPath + lcWebDir + "Sheet_" + Trim(Str(WebSheetsCount)) + ".htm"
                
                    For i = 1 To wsoRange.Columns.count
                        ColWidth(i) = wsoRange.Columns(wsoRange(1).column + i - 1).Width
                    Next i
                    Call PrintFile(lcTableFile, 0, "")
                    st_table = ""
                    curPosR = 1
                    WebSheets(WebSheetsCount).HBCount = 0

                Else
                    WebSheets(WebSheetsCount).HBCount = WebSheets(WebSheetsCount).HBCount + 1
                    WebSheets(WebSheetsCount).HB(WebSheets(WebSheetsCount).HBCount) = curPosR - 1
                End If
'/html ------------------------------------------------------
                
                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)
            On Error Resume Next
            lcFormula = .FormulaLocal
            If .Text = "#ССЫЛКА!" Then
                .FormulaLocal = lcFormula
            End If
            .Calculate
            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) Then 'And Not nxlPages Then
            If groupProp(curGr, 8) And groupProp(curGr, 9) <> "BR" Then
                groupProp(curGr, 8) = False
            Else
                WebSheets(WebSheetsCount).HBCount = WebSheets(WebSheetsCount).HBCount + 1
                WebSheets(WebSheetsCount).HB(WebSheets(WebSheetsCount).HBCount) = curPosR - 1
                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), groupProp(curGr, 5), _
                    groupProp(curGr, 6) And Not nxlFreezePanes)
            '!!!!!!!!!!!!!!!!!!!!!!
        End If
        
        startPosGr = curPosR

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


                With wso.Cells(gEndPosDet + 1, 8)
                    On Error Resume Next
                    lcFormula = .FormulaLocal
                    If .Text = "#ССЫЛКА!" Then
                       .FormulaLocal = lcFormula
                    End If
                    .Calculate
                    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
        If groupProp(curGr, 4) Then
            On Error Resume Next
'            wsr.Rows(Trim(Str(startPosGr)) + ":" + Trim(Str(endPosGr))).Group
            On Error GoTo 0
        End If
        ' Копирование концовки группы

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

        With wso.Cells(gEndPosF(curGr) + 1, 8)
            On Error Resume Next
            lcFormula = .FormulaLocal
            If .Text = "#ССЫЛКА!" Then
                .FormulaLocal = lcFormula
            End If
            .Calculate
            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, _
        Optional ByVal bTitleRows As Boolean = False, _
        Optional bFreezePanes As Boolean = False)
Dim c As Range, curRange As Range, lbText As Boolean, cText As String, _
    lcFormula As String, lbMerge As Boolean

    Set curRange = wso.Rows(Trim(Str(startPosRepl)) + ":" + Trim(Str(endPosRepl))) ' Диапазон
    rCurRow.value = curPosData
    rStartRow.value = startPosD
    rEndRow.value = endPosD


    On Error GoTo f3_m2

    For Each c In curRange.SpecialCells(xlCellTypeFormulas)
        With c
            lcFormula = .FormulaLocal
            If .Text = "#ССЫЛКА!" Then
                .FormulaLocal = lcFormula
            End If
            .Calculate
        End With
    Next c

'    curRange.Calculate
' запись вычисленных ячеек в html

'html -------------------------------------------------------
f3_m2:  On Error GoTo 0
        Call PrintFile(lcTableFile, 1, GetWebTableBody(curRange, bTitleRows, bFreezePanes))
'/html ------------------------------------------------------
'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) As String
Dim nPos1 As Integer, nPos2 As Integer, i As Long
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = InStr(nPos1 + 1, lcParam, "#")
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = InStr(nPos1 + 1, lcParam, "#")
    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(ByVal cWhere As String, ByVal cWhat As String, ByVal 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, nRow As Integer, rlc As Range, ss As Object
    Set ws = Application.ActiveWorkbook.ActiveSheet
    If ws.Visible <> xlSheetVeryHidden Then

'Изменение формирования имен листов для пакетной выгрузки
        fName = SheetsNames(ws.Index)

        If Not (fName Like "[#]*[#]*[#]*") Then
            fName = filePath + ws.name
        Else
            fName = filePath + fName
        End If
                
        On Error GoTo 0
        On Error GoTo ss02
        Workbooks.Open fileName:=fName + ".xls"

        nRow = LastCell(Cells).Row
        If nRow >= 5000 Then
            ws.Copy Before:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count)
        Else
            ws.Range(ws.Cells(1, 1), LastCell(ws.Cells)).EntireRow.Copy
            nRow = LastCell(Cells).Row
            ActiveSheet.Cells(nRow + 1, 1).Insert Shift:=xlDown
        End If
        ActiveSheet.HPageBreaks.Add Before:=ActiveSheet.Cells(nRow + 1, 1)
        ActiveWorkbook.Close SaveChanges:=True
                                
        GoTo ss01
ss02:   On Error GoTo 0
        ws.Copy
        ActiveWorkbook.SaveAs fileName:=fName + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
ss01:   On Error GoTo 0
    End If
    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 InitStyle()
Dim c As Object
    style.count = 0
    ReDim Preserve style.wc(1)
    Set c = ActiveWorkbook.Styles("Normal")
    With style.wc(0)
        .text_align = Switch(c.HorizontalAlignment = xlLeft, "left", _
            c.HorizontalAlignment = xlRight, "right", _
            c.HorizontalAlignment = xlCenter, "center", _
            c.HorizontalAlignment = xlGeneral, "general")
        .vertical_align = Switch(c.VerticalAlignment = xlTop, "top", _
            c.VerticalAlignment = xlBottom, "bottom", _
            c.VerticalAlignment = xlCenter, "middle")
        .white_space = IIf(c.WrapText, "normal", "nowrap")
        .mso_text_control = IIf(c.ShrinkToFit, "shrinktofit", "")
        .mso_number_format = c.NumberFormat
        .mso_number_format = StrReplace(.mso_number_format, "#", "\#")
        .mso_number_format = StrReplace(.mso_number_format, ",", "\,")
        .mso_number_format = StrReplace(.mso_number_format, ".", "\.")
        .font_family = c.Font.name
        .font_size = Trim(Str(c.Font.Size)) + "pt"
        .font_weight = IIf(c.Font.Bold, "700", "400")
        .text_decoration = IIf(c.Font.Underline = xlUnderlineStyleSingle, "underline", "none")
        .font_style = IIf(c.Font.Italic, "italic", "normal")
        .style = "style0"
        .background = IIf(c.Interior.ColorIndex <> xlColorIndexNone, "#" + StrReverse(Hex(c.Interior.color)), "")
        .color = "#" + Hex(c.Font.color)
        .mso_pattern = IIf(c.Interior.Pattern = xlPatternNone, "auto none", "")
    End With
End Sub

Sub AddStyle(r As Range)
Dim c As Range, rc As Integer, cAddr1 As String, cAddr2 As String, _
    cValue As String, tableWidth As Double, _
    i As Long, j As Integer, k As Integer, b As Boolean, _
    rHeight As Double, ws As WebStyle, _
    fval As String

    For i = r(1).Row To r(1).Row + r.Rows.count - 1
        wcs(i).row_height = 0
        wcs(i).count = 0
    Next i
    For Each c In r
        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)
                        fval = StrReplace(fval, "АДРЕС", "ADDRESS")
                        fval = StrReplace(fval, "СУММЕСЛИ", "SUMIF")
                        fval = StrReplace(fval, "ЯЧЕЙКА", "CELL")
                        fval = StrReplace(fval, "СУММ", "SUM")
                        fval = StrReplace(fval, "СТРОКА", "ROW")
                        fval = StrReplace(fval, "СТОЛБЕЦ", "COLUMN")
                        fval = StrReplace(fval, "ДВССЫЛ", "INDIRECT")
                        fval = StrReplace(fval, "ИСТИНА", "True")
                        fval = StrReplace(fval, "ЛОЖЬ", "False")
                        fval = StrReplace(fval, "НЕ", "NOT")
                        fval = StrReplace(fval, "ЕПУСТО", "ISBLANK")
                        fval = StrReplace(fval, "СЖПРОБЕЛЫ", "TRIM")
                        fval = StrReplace(fval, "ЕСЛИ", "IF")
                        fval = StrReplace(fval, ";", ",")
                        c.FormulaLocal = fval
                    End If
                Else
                    c.FormulaLocal = "=" + Mid(fval, 4)
                    c.WrapText = True
'                    c.AddComment ("Eval")
                End If
            End If
            rc = c.Row
            wcs(rc).count = wcs(rc).count + 1
            ReDim Preserve wcs(rc).wc(wcs(rc).count)
            With ws
                wcs(rc).wc(wcs(rc).count).column = c.column - r(1).column + 1
                wcs(rc).wc(wcs(rc).count).colspan = Trim(Str(c.MergeArea.Columns.count))
                wcs(rc).wc(wcs(rc).count).rowspan = Trim(Str(c.MergeArea.Rows.count))
                If wcs(rc).wc(wcs(rc).count).rowspan > 1 Then
                    For i = 1 To wcs(rc).wc(wcs(rc).count).rowspan - 1
                        wcs(rc + i).row_height = -1
                    Next i
                End If
                If Not c.WrapText And c.MergeArea.Rows.count = 1 Then
                    If wcs(rc).row_height >= 0 Then
                        wcs(rc).row_height = IIf(c.Height > wcs(rc).row_height, c.Height, wcs(rc).row_height)
                    End If
                Else
                    wcs(rc).row_height = -1
                End If
                .text_align = Switch(c.HorizontalAlignment = xlLeft, "left", _
                    c.HorizontalAlignment = xlRight, "right", _
                    c.HorizontalAlignment = xlCenter, "center", _
                    c.HorizontalAlignment = -4130 Or c.HorizontalAlignment = xlGeneral Or c.HorizontalAlignment = xlHAlignCenterAcrossSelection, "general")
                .vertical_align = Switch(c.VerticalAlignment = xlTop, "top", _
                    c.VerticalAlignment = xlBottom, "bottom", _
                    c.VerticalAlignment = xlCenter, "middle", _
                    c.VerticalAlignment <> xlTop And c.VerticalAlignment <> xlBottom And c.VerticalAlignment <> xlCenter, "bottom")
                .white_space = IIf(c.WrapText, "normal", "nowrap")
                .mso_text_control = IIf(c.ShrinkToFit, "shrinktofit", "")
                .mso_number_format = c.NumberFormat
                .mso_number_format = StrReplace(.mso_number_format, "#", "\#")
                .mso_number_format = StrReplace(.mso_number_format, ",", "\,")
                .mso_number_format = StrReplace(.mso_number_format, ".", "\.")
                .font_family = c.Font.name
                .font_size = Trim(Str(c.Font.Size)) + "pt"
                .font_weight = IIf(c.Font.Bold, "700", "400")
                .text_decoration = IIf(c.Font.Underline = xlUnderlineStyleSingle, "underline", "none")
                .font_style = IIf(c.Font.Italic, "italic", "normal")
                If c.Borders(xlEdgeLeft).LineStyle <> xlNone Then
                    .border_left = Switch(c.Borders(xlEdgeLeft).LineStyle = xlDouble, "2.5pt double windowtext", _
                        c.Borders(xlEdgeLeft).Weight = xlThin, ".5pt solid  windowtext", _
                        c.Borders(xlEdgeLeft).Weight = xlMedium, "1.0pt solid  windowtext", _
                        c.Borders(xlEdgeLeft).Weight = xlThick, "1.5pt solid  windowtext", _
                        c.Borders(xlEdgeLeft).Weight = xlHairline, "")
                Else
                    .border_left = ""
                End If
                If c.Borders(xlEdgeRight).LineStyle <> xlNone Then
                    .border_right = Switch(c.Borders(xlEdgeRight).LineStyle = xlDouble, "2.5pt double windowtext", _
                        c.Borders(xlEdgeRight).Weight = xlThin, ".5pt solid  windowtext", _
                        c.Borders(xlEdgeRight).Weight = xlMedium, "1.0pt solid  windowtext", _
                        c.Borders(xlEdgeRight).Weight = xlThick, "1.5pt solid  windowtext", _
                        c.Borders(xlEdgeRight).Weight = xlHairline, "")
                Else
                    .border_right = ""
                End If
                If c.Borders(xlEdgeTop).LineStyle <> xlNone Then
                    .border_top = Switch(c.Borders(xlEdgeTop).LineStyle = xlDouble, "2.5pt double windowtext", _
                        c.Borders(xlEdgeTop).Weight = xlThin, ".5pt solid  windowtext", _
                        c.Borders(xlEdgeTop).Weight = xlMedium, "1.0pt solid  windowtext", _
                        c.Borders(xlEdgeTop).Weight = xlThick, "1.5pt solid  windowtext", _
                        c.Borders(xlEdgeTop).Weight = xlHairline, "")
                Else
                    .border_top = ""
                End If
                If c.Borders(xlEdgeBottom).LineStyle <> xlNone Then
                    .border_bottom = Switch(c.Borders(xlEdgeBottom).LineStyle = xlDouble, "2.5pt double windowtext", _
                        c.Borders(xlEdgeBottom).Weight = xlThin, ".5pt solid  windowtext", _
                        c.Borders(xlEdgeBottom).Weight = xlMedium, "1.0pt solid  windowtext", _
                        c.Borders(xlEdgeBottom).Weight = xlThick, "1.5pt solid  windowtext", _
                        c.Borders(xlEdgeBottom).Weight = xlHairline, "")
                Else
                    .border_bottom = ""
                End If
                .background = IIf(c.Interior.ColorIndex <> xlColorIndexNone, "#" + StrReverse(Hex(c.Interior.color)), "")
                .color = "#" + Hex(c.Font.color)
                b = False
                For k = 1 To style.count
                    b = _
                    (.border_bottom = style.wc(k).border_bottom) And _
                    (.border_left = style.wc(k).border_left) And _
                    (.border_right = style.wc(k).border_right) And _
                    (.border_top = style.wc(k).border_top) And _
                    (.font_family = style.wc(k).font_family) And _
                    (.font_size = style.wc(k).font_size) And _
                    (.font_style = style.wc(k).font_style) And _
                    (.font_weight = style.wc(k).font_weight) And _
                    (.mso_number_format = style.wc(k).mso_number_format) And _
                    (.mso_text_control = style.wc(k).mso_text_control) And _
                    (.text_align = style.wc(k).text_align) And _
                    (.text_decoration = style.wc(k).text_decoration) And _
                    (.vertical_align = style.wc(k).vertical_align) And _
                    (.background = style.wc(k).background) And _
                    (.color = style.wc(k).color) And _
                    (.white_space = style.wc(k).white_space)
                    If b Then Exit For
                Next k
                If b Then
                    .style = style.wc(k).style
                Else
                    style.count = style.count + 1
                    ReDim Preserve style.wc(style.count)
                    style.wc(style.count).style = "xl" + Trim(Str(style.count + 20))
                    .style = style.wc(style.count).style
                    style.wc(style.count).mso_style_parent = style.wc(0).style
                    style.wc(style.count).border_bottom = .border_bottom
                    style.wc(style.count).border_left = .border_left
                    style.wc(style.count).border_right = .border_right
                    style.wc(style.count).border_top = .border_top
                    style.wc(style.count).font_family = .font_family
                    style.wc(style.count).font_size = .font_size
                    style.wc(style.count).font_style = .font_style
                    style.wc(style.count).font_weight = .font_weight
                    style.wc(style.count).mso_number_format = .mso_number_format
                    style.wc(style.count).mso_text_control = .mso_text_control
                    style.wc(style.count).text_align = .text_align
                    style.wc(style.count).text_decoration = .text_decoration
                    style.wc(style.count).vertical_align = .vertical_align
                    style.wc(style.count).white_space = .white_space
                    style.wc(style.count).background = .background
                    style.wc(style.count).color = .color
                End If
                wcs(rc).wc(wcs(rc).count).style = .style
            End With
        End If
    Next c
End Sub

Function GetWebSheetBegin(r As Range, Optional TopColontitul As String = "") As String
Dim i As Long, st As String, BotColontitul As String
    st = ""
    On Error GoTo PErr3
    If TopColontitul = "" Then
        TopColontitul = IIf(ActiveSheet.PageSetup.LeftHeader <> "", "&Л" + ActiveSheet.PageSetup.LeftHeader, "") + _
                        IIf(ActiveSheet.PageSetup.CenterHeader <> "", "&Ц" + ActiveSheet.PageSetup.CenterHeader, "") + _
                        IIf(ActiveSheet.PageSetup.RightHeader <> "", "&П" + ActiveSheet.PageSetup.RightHeader, "")
    End If
    BotColontitul = IIf(ActiveSheet.PageSetup.LeftFooter <> "", "&Л" + ActiveSheet.PageSetup.LeftFooter, "") + _
                    IIf(ActiveSheet.PageSetup.CenterFooter <> "", "&Ц" + ActiveSheet.PageSetup.CenterFooter, "") + _
                    IIf(ActiveSheet.PageSetup.RightFooter <> "", "&П" + ActiveSheet.PageSetup.RightFooter, "")
PErr3: On Error GoTo 0
    TopColontitul = StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(TopColontitul, "&B", "&Ж"), "&P", "&С"), "&N", "&К"), "&D", "&Д"), "&T", "&В"), "&F", "&Ф"), "&A", "&Я")
    BotColontitul = StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(StrReplace(BotColontitul, "&B", "&Ж"), "&P", "&С"), "&N", "&К"), "&D", "&Д"), "&T", "&В"), "&F", "&Ф"), "&A", "&Я")

    BotColontitul = StrReplace(BotColontitul, Chr(10), "\000A")
    TopColontitul = StrReplace(TopColontitul, Chr(10), "\000A")

    If Val(Application.Version) >= 12 Then
        BotColontitul = StrReplace(BotColontitul, "&Л", "&L")
        BotColontitul = StrReplace(BotColontitul, "&Ц", "&C")
        BotColontitul = StrReplace(BotColontitul, "&П", "&R")
        BotColontitul = StrReplace(BotColontitul, "&Ж", "&B")
        BotColontitul = StrReplace(BotColontitul, "&С", "&P")
        BotColontitul = StrReplace(BotColontitul, "&К", "&N")
        BotColontitul = StrReplace(BotColontitul, "&Д", "&D")
        BotColontitul = StrReplace(BotColontitul, "&В", "&T")
        BotColontitul = StrReplace(BotColontitul, "&Ф", "&F")
      
        TopColontitul = StrReplace(TopColontitul, "&Л", "&L")
        TopColontitul = StrReplace(TopColontitul, "&Ц", "&C")
        TopColontitul = StrReplace(TopColontitul, "&П", "&R")
        TopColontitul = StrReplace(TopColontitul, "&Ж", "&B")
        TopColontitul = StrReplace(TopColontitul, "&С", "&P")
        TopColontitul = StrReplace(TopColontitul, "&К", "&N")
        TopColontitul = StrReplace(TopColontitul, "&Д", "&D")
        TopColontitul = StrReplace(TopColontitul, "&В", "&T")
        TopColontitul = StrReplace(TopColontitul, "&Ф", "&F")
    End If

    lcStyleOptions = _
              "<style>" + Chr(10) + _
              "<!--table" + Chr(10) + _
              Chr(9) + "{mso-displayed-decimal-separator:""\,"";" + Chr(10) + _
              Chr(9) + "mso-displayed-thousand-separator:"" "";}" + Chr(10)
    lcStyleOptions = lcStyleOptions + _
              "@page" + Chr(10) + _
              Chr(9) + "{" + _
              IIf(TopColontitul <> "", Chr(10) + Chr(9) + "mso-header-data:""" + TopColontitul + """;", "") + _
              IIf(BotColontitul <> "", Chr(10) + Chr(9) + "mso-footer-data:""" + BotColontitul + """;", "") + _
              Chr(10) + Chr(9) + "margin:" + _
              Trim(Str(r.Parent.PageSetup.TopMargin / 72)) + "in " + _
              Trim(Str(r.Parent.PageSetup.RightMargin / 72)) + "in " + _
              Trim(Str(r.Parent.PageSetup.BottomMargin / 72)) + "in " + _
              Trim(Str(r.Parent.PageSetup.LeftMargin / 72)) + "in;" + Chr(10) + _
              Chr(9) + "mso-header-margin:" + Trim(Str(r.Parent.PageSetup.HeaderMargin / 72)) + "in;" + Chr(10) + _
              Chr(9) + "mso-footer-margin:" + Trim(Str(r.Parent.PageSetup.FooterMargin / 72)) + "in;" + _
              IIf(TopColontitul <> "", Chr(10) + Chr(9) + "mso-header-data:""" + TopColontitul + """;", "") + _
              IIf(BotColontitul <> "", Chr(10) + Chr(9) + "mso-footer-data:""" + BotColontitul + """;", "") + _
              IIf(ActiveSheet.PageSetup.Orientation = xlLandscape, Chr(10) + Chr(9) + "mso-page-orientation:landscape;", "") + _
              "}" + Chr(10)
    lcStyleOptions = lcStyleOptions + _
              "-->" + Chr(10) + _
              "</style>" + Chr(10)

    st = st + "<html xmlns:x=""urn:schemas-microsoft-com:office:excel"">" + Chr(10) + "<head>" + Chr(10) + _
              "<meta name=ProgId content=Excel.Sheet>" + Chr(10) + _
              "<meta http-equiv=Content-Type content=""text/html; charset=windows-1251"">" + Chr(10) + _
              "<link rel=Stylesheet href=stylesheet.css>" + Chr(10) + _
              lcStyleOptions

    On Error GoTo PErr4
    WebSheets(WebSheetsCount).DisplayGridLines = IIf(Not ActiveWindow.DisplayGridLines, "<x:DoNotDisplayGridlines/>", "")
    WebSheets(WebSheetsCount).DisplayZeros = IIf(Not ActiveWindow.DisplayZeros, "<x:DoNotDisplayZeros/>", "")
    WebSheets(WebSheetsCount).FitToPage = IIf(ActiveSheet.PageSetup.Zoom, "", "<x:FitToPage/>")
    WebSheets(WebSheetsCount).FitWidth = IIf(ActiveSheet.PageSetup.FitToPagesWide > 0, "<x:FitWidth>" + Trim(Str(ActiveSheet.PageSetup.FitToPagesWide)) + "</x:FitWidth>", "<x:FitWidth>0</x:FitWidth>")
    WebSheets(WebSheetsCount).FitHeight = IIf(ActiveSheet.PageSetup.FitToPagesTall > 0, "<x:FitHeight>" + Trim(Str(ActiveSheet.PageSetup.FitToPagesTall)) + "</x:FitHeight>", "<x:FitHeight>0</x:FitHeight>")
    WebSheets(WebSheetsCount).FitToPage = IIf(ActiveSheet.PageSetup.Zoom, "", "<x:FitToPage/>")
    WebSheets(WebSheetsCount).Zoom = IIf(ActiveSheet.PageSetup.Zoom, "<x:Scale>" + Trim(Str(ActiveSheet.PageSetup.Zoom)) + "</x:Scale>", "")
    WebSheets(WebSheetsCount).PaperSizeIndex = "<x:PaperSizeIndex>" + Trim(Str(ActiveSheet.PageSetup.PaperSize)) + "</x:PaperSizeIndex>"

PErr4:    On Error GoTo 0

    lcSheetOptions = _
              IIf(WebSheets(WebSheetsCount).FitToPage <> "", "     " + WebSheets(WebSheetsCount).FitToPage + Chr(10), "") + _
              "     <x:Print>" + Chr(10) + _
              IIf(lbBlackAndWhite, "      <x:BlackAndWhite/>" + Chr(10), "") + _
              IIf(WebSheets(WebSheetsCount).Zoom <> "", "      " + WebSheets(WebSheetsCount).Zoom + Chr(10), "") + _
              IIf(WebSheets(WebSheetsCount).PaperSizeIndex <> "", "      " + WebSheets(WebSheetsCount).PaperSizeIndex + Chr(10), "") + _
              IIf(WebSheets(WebSheetsCount).FitWidth <> "", "      " + WebSheets(WebSheetsCount).FitWidth + Chr(10), "") + _
              IIf(WebSheets(WebSheetsCount).FitHeight <> "", "      " + WebSheets(WebSheetsCount).FitHeight + Chr(10), "") + _
              "      <x:ValidPrinterInfo/>" + Chr(10) + _
              "     </x:Print>" + Chr(10) + _
              IIf(WebSheets(WebSheetsCount).DisplayGridLines <> "", "     " + WebSheets(WebSheetsCount).DisplayGridLines + Chr(10), "") + _
              IIf(WebSheets(WebSheetsCount).DisplayZeros <> "", "     " + WebSheets(WebSheetsCount).DisplayZeros + Chr(10), "")

    st = st + "<!--[if gte mso 9]><xml>" + Chr(10) + _
              "    <x:WorksheetOptions>" + Chr(10) + _
              lcSheetOptions + _
              "    </x:WorksheetOptions>" + Chr(10) + _
              "</xml><![endif]-->" + Chr(10)

    st = st + "</head>" + Chr(10) + _
              "<body>" + Chr(10)
    For i = 1 To r.Columns.count
        ColWidth(i) = r.Columns(r(1).column + i - 1).Width
    Next i
    curPosR = 1
    WebSheets(WebSheetsCount).TitleColumns = ActiveSheet.PageSetup.PrintTitleColumns
    WebSheets(WebSheetsCount).TitleRows = ActiveSheet.PageSetup.printTitleRows
    GetWebSheetBegin = st
End Function
              
Function GetWebStylesDeclare() As String
Dim i As Long, st As String
    st = st + "tr" + Chr(10) + Chr(9) + "{mso-height-source:auto;}" + Chr(10)
    st = st + "col" + Chr(10) + Chr(9) + "{mso-width-source:auto;}" + Chr(10)
    st = st + "br" + Chr(10) + Chr(9) + "{mso-data-placement:same-cell;}" + Chr(10)
    st = st + "." + style.wc(0).style + Chr(10) + _
              Chr(9) + "{font-family:""" + style.wc(0).font_family + """;" + Chr(10) + _
              Chr(9) + "font-size:" + style.wc(0).font_size + ";" + Chr(10) + _
              Chr(9) + "font-style:" + style.wc(0).font_style + ";" + Chr(10) + _
              Chr(9) + "font-weight:" + style.wc(0).font_weight + ";" + Chr(10) + _
              Chr(9) + "mso-number-format:" + IIf(style.wc(0).mso_number_format <> "0", style.wc(0).mso_number_format, """@""") + ";" + Chr(10) + _
              Chr(9) + "mso-text-control:" + style.wc(0).mso_text_control + ";" + Chr(10) + _
              Chr(9) + "text-align:" + style.wc(0).text_align + ";" + Chr(10) + _
              Chr(9) + "text-decoration:" + style.wc(0).text_decoration + ";" + Chr(10) + _
              Chr(9) + "vertical-align:" + style.wc(0).vertical_align + ";" + Chr(10) + _
              Chr(9) + "white-space:" + style.wc(0).white_space + ";" + Chr(10) + _
              Chr(9) + "mso-rotate:0;" + Chr(10) + _
              Chr(9) + "mso-background-source:auto;" + Chr(10) + _
              Chr(9) + "color:windowtext;" + Chr(10) + _
              Chr(9) + "mso-generic-font-family:auto;" + Chr(10) + _
              Chr(9) + "mso-font-charset:204;" + Chr(10) + _
              Chr(9) + "border:none;" + Chr(10) + _
              IIf(style.wc(0).mso_pattern <> "", _
                  Chr(9) + "mso-pattern:" + style.wc(0).mso_pattern + ";" + Chr(10), "") + _
              Chr(9) + "mso-protection:locked visible;" + Chr(10) + _
              Chr(9) + "mso-style-name:Обычный;" + Chr(10) + _
              Chr(9) + "mso-style-id:0;}" + Chr(10)
    st = st + "td" + Chr(10) + _
              Chr(9) + "{mso-style-parent:" + style.wc(0).style + Chr(10) + _
              Chr(9) + "padding-top:1px;padding-right:1px;padding-left:1px;mso-ignore:padding;" + Chr(10) + _
              Chr(9) + "font-family:""" + style.wc(0).font_family + """;" + Chr(10) + _
              Chr(9) + "font-size:" + style.wc(0).font_size + ";" + Chr(10) + _
              Chr(9) + "font-style:" + style.wc(0).font_style + ";" + Chr(10) + _
              Chr(9) + "font-weight:" + style.wc(0).font_weight + ";" + Chr(10) + _
              Chr(9) + "mso-number-format:" + IIf(style.wc(0).mso_number_format <> "0", style.wc(0).mso_number_format, """@""") + ";" + Chr(10) + _
              Chr(9) + "mso-text-control:" + style.wc(0).mso_text_control + ";" + Chr(10) + _
              Chr(9) + "text-align:" + style.wc(0).text_align + ";" + Chr(10) + _
              Chr(9) + "text-decoration:" + style.wc(0).text_decoration + ";" + Chr(10) + _
              Chr(9) + "vertical-align:" + style.wc(0).vertical_align + ";" + Chr(10) + _
              Chr(9) + "white-space:" + style.wc(0).white_space + ";" + Chr(10) + _
              Chr(9) + "mso-rotate:0;" + Chr(10) + _
              Chr(9) + "mso-background-source:auto;" + Chr(10) + _
              Chr(9) + "color:windowtext;" + Chr(10) + _
              Chr(9) + "mso-generic-font-family:auto;" + Chr(10) + _
              Chr(9) + "mso-font-charset:204;" + Chr(10) + _
              Chr(9) + "border:none;" + Chr(10) + _
              IIf(style.wc(0).mso_pattern <> "", _
                  Chr(9) + "mso-pattern:" + style.wc(0).mso_pattern + ";" + Chr(10), "") + _
              Chr(9) + "mso-protection:locked visible;}" + Chr(10)
    For i = 1 To style.count
        With style.wc(i)
            st = st + "." + style.wc(i).style + Chr(10) + _
            Chr(9) + "{mso-style-parent:" + style.wc(i).mso_style_parent + ";" + Chr(10) + _
            IIf(.font_family <> style.wc(0).font_family, _
                Chr(9) + "font-family:""" + style.wc(i).font_family + """;" + Chr(10), "") + _
            IIf(.font_size <> style.wc(0).font_size, _
                Chr(9) + "font-size:" + style.wc(i).font_size + ";" + Chr(10), "") + _
            IIf(.font_style <> style.wc(0).font_style, _
                Chr(9) + "font-style:" + style.wc(i).font_style + ";" + Chr(10), "") + _
            IIf(.font_weight <> style.wc(0).font_weight, _
                Chr(9) + "font-weight:" + style.wc(i).font_weight + ";" + Chr(10), "") + _
            IIf(.mso_number_format <> style.wc(0).mso_number_format, _
                Chr(9) + "mso-number-format:" + IIf(style.wc(i).mso_number_format <> "0", style.wc(i).mso_number_format, """@""") + ";" + Chr(10), "") + _
            IIf(.mso_text_control <> style.wc(0).mso_text_control, _
                Chr(9) + "mso-text-control:" + style.wc(i).mso_text_control + ";" + Chr(10), "") + _
            IIf(.text_align <> style.wc(0).text_align, _
                Chr(9) + "text-align:" + style.wc(i).text_align + ";" + Chr(10), "") + _
            IIf(.text_decoration <> style.wc(0).text_decoration, _
                Chr(9) + "text-decoration:" + style.wc(i).text_decoration + ";" + Chr(10), "") + _
            IIf(.vertical_align <> style.wc(0).vertical_align, _
                Chr(9) + "vertical-align:" + style.wc(i).vertical_align + ";" + Chr(10), "") + _
            IIf(.white_space <> style.wc(0).white_space, _
                Chr(9) + "white-space:" + style.wc(i).white_space + ";" + Chr(10), "")
            st = st + _
            IIf(.border_bottom <> "", _
                Chr(9) + "border-bottom:" + style.wc(i).border_bottom + ";" + Chr(10), "") + _
            IIf(.border_left <> "", _
                Chr(9) + "border-left:" + style.wc(i).border_left + ";" + Chr(10), "") + _
            IIf(.border_right <> "", _
                Chr(9) + "border-right:" + style.wc(i).border_right + ";" + Chr(10), "") + _
            IIf(.border_top <> "", _
                Chr(9) + "border-top:" + style.wc(i).border_top + ";" + Chr(10), "") + _
            IIf(.background <> "", _
                Chr(9) + "background:" + style.wc(i).background + ";" + Chr(10), "") + _
            IIf(.color <> "", _
                Chr(9) + "color:" + style.wc(i).color + ";" + Chr(10), "") + _
            Chr(9) + "}" + Chr(10)
        End With
    Next i
    GetWebStylesDeclare = st
End Function
    
Function GetWebTableDeclare(r As Range)
Dim i As Long, st As String, tableWidth As Double
    st = "<table x:str border=0 cellpadding=0 cellspacing=0 style='border-collapse:collapse;" + Chr(10)
    tableWidth = 0
    For i = 1 To r.Columns.count
        tableWidth = tableWidth + ColWidth(i)
    Next i
    st = st + " table-layout:fixed;width:" + Str(tableWidth) + "pt'>" + Chr(10)
    GetWebTableDeclare = st
End Function

Function GetWebColDeclare(r As Range) As String
Dim i As Long, st As String
    st = ""
    For i = 1 To r.Columns.count
        st = st + " <col style='mso-width-source:userset;width:" + Str(ColWidth(i)) + "pt'>" + Chr(10)
    Next i
    GetWebColDeclare = st
End Function

Function GetWebTableBody(r As Range, Optional bTitleRows As Boolean = False, Optional bFreezePanes As Boolean = False) As String
Dim cValue As String, _
    i As Long, j As Integer, k As Integer, tr As Long, _
    rHeight As Double, st As String, cr As Range
    st = ""
    tr = curPosR
    For i = r(1).Row To r(1).Row + r.Rows.count - 1
        rHeight = wcs(i).row_height
        If rHeight <> 0 Then
            curPosR = curPosR + 1
            rHeight = 96 / 72 * rHeight 'Application.DefaultWebOptions.PixelsPerInch
            st = st + IIf(rHeight > 0, " <![if gte mso 9]> <tr> <![endif]> <![if lt mso 9]> <tr height=" + Trim(Str(rHeight)) + "> <![endif]>", " <tr>") + Chr(10)
            For j = 1 To wcs(i).count
                Set cr = r.Parent.Cells(i, r(1).column + wcs(i).wc(j).column - 1)
                cValue = cr.Text
                If Len(cValue) = 1024 Then
                    cValue = cr.value
                End If

                If InStr(cValue, "#Н/Д") > 0 Then
                    For k = wcs(i).wc(j).column To wcs(i).wc(j).column + wcs(i).wc(j).colspan - 1
                        ColWidth(k) = 0
                    Next k
                End If
                If WebSheets(1).DisplayZeros <> "" And cValue <> "" Then
                    If cr.value = 0 Then
                        cValue = ""
                    End If
                End If

                If Left(cValue, 3) = ">>=" Then
                    cValue = Mid(cValue, 3)
                    cValue = StrReplace(cValue, "&", "&amp;")
                    cValue = StrReplace(cValue, ">", "&gt;")
                    cValue = StrReplace(cValue, "<", "&lt;")
                    cValue = StrReplace(cValue, """", "&quot;")
                    cValue = StrReplace(cValue, Chr(10) + Chr(13), "</span><br><span style=""mso-spacerun: yes"">")
                    cValue = StrReplace(cValue, Chr(10), "</span><br><span style=""mso-spacerun: yes"">")
                    cValue = StrReplace(cValue, " ", Chr(160))
                    st = st + "  <td class=" + _
                        wcs(i).wc(j).style + " " + _
                        IIf(wcs(i).wc(j).colspan > 1, "colspan=" + wcs(i).wc(j).colspan + " ", "") + _
                        IIf(wcs(i).wc(j).rowspan > 1, "rowspan=" + wcs(i).wc(j).rowspan + " ", "") + _
                        "x:fmla=""" + cValue + """ ></td>" + Chr(10)
                Else
                    cValue = StrReplace(cValue, "&", "&amp;")
                    cValue = StrReplace(cValue, ">", "&gt;")
                    cValue = StrReplace(cValue, "<", "&lt;")
                    cValue = StrReplace(cValue, """", "&quot;")
                    cValue = StrReplace(cValue, Chr(10) + Chr(13), "</span><br><span style=""mso-spacerun: yes"">")
                    cValue = StrReplace(cValue, Chr(10), "</span><br><span style=""mso-spacerun: yes"">")
                    cValue = StrReplace(cValue, " ", Chr(160))
                    st = st + "  <td class=" + _
                        wcs(i).wc(j).style + " " + _
                        IIf(wcs(i).wc(j).colspan > 1, "colspan=" + wcs(i).wc(j).colspan + " ", "") + _
                        IIf(wcs(i).wc(j).rowspan > 1, "rowspan=" + wcs(i).wc(j).rowspan + " ", "") + _
                        IIf(InStr(1, cr.NumberFormat, "0") > 0 And cr.NumberFormat <> "0", "x:num=""" & StrReplace(cr.value, ",", ".") & """", "") + _
                        "><span style=""mso-spacerun: yes"">" + cValue + "</span></td>" + Chr(10)
                End If
            Next j
            st = st + " </tr>" + Chr(10)
        End If
    Next i
    If curPosR > tr And bTitleRows Then WebSheets(WebSheetsCount).TitleRows = "$" + Trim(Str(tr)) + ":$" + Trim(Str(curPosR - 1))
    If curPosR > tr And bFreezePanes And lbFreeze Then
        lbFreeze = False
        st_begin_sheet = st_begin_sheet + _
        "<!--[if gte mso 9]><xml>" + Chr(10) + _
        "    <x:WorksheetOptions>" + Chr(10) + _
        lcSheetOptions + _
        "     <x:FreezePanes/>" + Chr(10) + _
        "     <x:FrozenNoSplit/>" + Chr(10) + _
        "     <x:SplitHorizontal>" + Trim(Str(curPosR - 1)) + "</x:SplitHorizontal>" + Chr(10) + _
        "     <x:TopRowBottomPane>" + Trim(Str(curPosR - 1)) + "</x:TopRowBottomPane>" + Chr(10) + _
        "    </x:WorksheetOptions>" + Chr(10) + _
        "</xml><![endif]-->" + Chr(10) + _
        lcStyleOptions + Chr(10)
    End If
    GetWebTableBody = st
End Function

Function GetWebSheetEnd() As String
Dim st As String, i As Long

    st = ""
    If WebSheets(WebSheetsCount).HBCount > 0 Then
        st = st + _
         "<!--[if gte mso 9]><xml>" + Chr(10) + _
         "    <x:PageBreaks>" + Chr(10) + _
         "     <x:RowBreaks>" + Chr(10)
        For i = 1 To WebSheets(WebSheetsCount).HBCount
            st = st + _
             "      <x:RowBreak> " + "<x:Row>" + Trim(Str(WebSheets(WebSheetsCount).HB(i))) + "</x:Row> </x:RowBreak>" + Chr(10)
        Next i
        st = st + _
         "     </x:RowBreaks>" + Chr(10) + _
         "    </x:PageBreaks>" + Chr(10) + _
         "</xml><![endif]-->" + Chr(10)
    End If

    st = st + "</table>" + Chr(10)
    st = st + "</body>" + Chr(10)
    st = st + "</html>" + Chr(10)
    GetWebSheetEnd = st
End Function

Function StrReverse(st As String) As String
Dim st_r As String, i As Long
    st_r = ""
    For i = 1 To Len(st)
        st_r = Mid(st, i, 1) + st_r
    Next i
    StrReverse = st_r
End Function

Function GetWebTabStrip() As String
Dim i As Long, st As String
    st = "<html>" + Chr(10) + "<head>" + Chr(10) + _
         "<meta http-equiv=Content-Type content=""text/html; charset=windows-1251"">" + Chr(10) + _
         "<style> <!-- A {text-decoration:none;color:#000000;font-size:9pt;font-family:""Arial Cyr"";} --> </style>" + Chr(10) + _
         "</head>" + Chr(10) + _
         "<body topmargin=0 leftmargin=0 bgcolor=""#808080"">" + Chr(10) + _
         "<table border=0 cellspacing=1>" + Chr(10) + _
         " <tr>" + Chr(10)
    For i = 1 To WebSheetsCount
        st = st + "  <td bgcolor=""#FFFFFF"" nowrap><b><small><small>&nbsp;<a href=" + _
                  """Sheet_" + Trim(Str(i)) + ".htm"" target=""frSheet"">" + _
                  WebSheets(i).name + "</a>&nbsp;</small></small></b></td>" + Chr(10)
    Next i
    st = st + " </tr>" + Chr(10) + "</table>" + Chr(10) + "</body>" + Chr(10) + "</html>"
    GetWebTabStrip = st
End Function

Function GetWebFileList() As String
Dim i As Long, st As String
    st = "<xml xmlns:o=""urn:schemas-microsoft-com:office:office"">" + Chr(10) + _
         " <o:MainFile HRef=""../" + lcWorkBook + """/>" + Chr(10) + _
         " <o:File HRef=""stylesheet.css""/>" + Chr(10) + _
         " <o:File HRef=""tabstrip.htm""/>" + Chr(10) + _
         " <o:File HRef=""filelist.xml""/>" + Chr(10)
    For i = 1 To WebSheetsCount
        st = st + " <o:File HRef=""Sheet_" + Trim(Str(i)) + ".htm""/>" + Chr(10)
    Next i
    st = st + "</xml>"
    GetWebFileList = st
End Function

Function GetWebMain() As String
Dim i As Long, st As String
    st = "<html xmlns:x=""urn:schemas-microsoft-com:office:excel"">" + Chr(10) + _
         "<head>" + Chr(10) + _
         "<meta name=""Excel Workbook Frameset"">" + Chr(10) + _
         "<meta http-equiv=Content-Type content=""text/html; charset=windows-1251"">" + Chr(10) + _
         "<meta name=Generator content=""Microsoft Excel 9"">" + Chr(10) + _
         "<link rel=File-List href=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/filelist.xml"">" + Chr(10)
    For i = 1 To WebSheetsCount
        st = st + "<link id=""shLink"" href=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/Sheet_" + Trim(Str(i)) + ".htm"">" + Chr(10)
    Next i
    st = st + _
         "<link id=""shLink"">" + Chr(10) + _
         "<!--[if gte mso 9]><xml>" + Chr(10) + _
         " <x:ExcelWorkbook>" + Chr(10) + _
         "  <x:ExcelWorksheets>" + Chr(10)
    For i = 1 To WebSheetsCount
        st = st + _
         "   <x:ExcelWorksheet>" + Chr(10) + _
         "    <x:Name>" + WebSheets(i).name + "</x:Name>" + Chr(10) + _
         "    <x:WorksheetSource HRef=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/Sheet_" + Trim(Str(i)) + ".htm""/>" + Chr(10) + _
         "   </x:ExcelWorksheet>" + Chr(10)
    Next i
    st = st + _
         "  </x:ExcelWorksheets>" + Chr(10) + _
         "  <x:Stylesheet HRef=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/stylesheet.css""/>" + Chr(10) + _
         "  <x:ActiveSheet>1</x:ActiveSheet>" + Chr(10) + _
         "  <x:ProtectStructure>False</x:ProtectStructure>" + Chr(10) + _
         "  <x:ProtectWindows>False</x:ProtectWindows>" + Chr(10) + _
         " </x:ExcelWorkbook>" + Chr(10)
    For i = 1 To WebSheetsCount
        If WebSheets(i).TitleColumns <> "" Or WebSheets(i).TitleRows <> "" Then
            st = st + _
             " <x:ExcelName>" + Chr(10) + _
             "  <x:Name>Print_Titles</x:Name>" + Chr(10) + _
             "  <x:SheetIndex>" + Trim(Str(i)) + "</x:SheetIndex>" + Chr(10) + _
             "  <x:Formula>=" + _
             IIf(WebSheets(i).TitleColumns <> "", WebSheets(i).name + "!" + WebSheets(i).TitleColumns, "") + _
             IIf(WebSheets(i).TitleRows <> "", _
                IIf(WebSheets(i).TitleColumns <> "", ",", "") + _
                WebSheets(i).name + "!" + WebSheets(i).TitleRows, "") + _
             "</x:Formula>" + Chr(10) + _
             " </x:ExcelName>" + Chr(10)
        End If
    Next i
    st = st + _
         "</xml><![endif]-->" + Chr(10) + _
         "</head>" + Chr(10) + _
         "<frameset rows=""*,39"" border=0 width=0 frameborder=no framespacing=0>" + Chr(10) + _
         " <frame src=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/Sheet_" + Trim(Str(WebSheetsCount)) + ".htm"" name=""frSheet"">" + Chr(10) + _
         " <frame src=""./" + Mid(lcWebDir, 1, Len(lcWebDir) - 1) + "/tabstrip.htm"" name=""frTabs"" marginwidth=0 marginheight=0>" + Chr(10) + _
         " <noframes>" + Chr(10) + _
         "  <body>" + Chr(10) + _
         "   <p>This page uses frames, but your browser doesn't support them.</p>" + Chr(10) + _
         "  </body>" + Chr(10) + _
         " </noframes>" + Chr(10) + _
         "</frameset>" + Chr(10) + _
         "</html>"
    GetWebMain = st
End Function

Sub AppendFileFormFile(lcFileDesc As String, lcFileSrc As String)
Dim a As String
    Open lcFileSrc For Input As #1
    Open lcFileDesc For Append As #2
    If LOF(1) = 0 Then GoTo q
    Do While Not EOF(1)
        Line Input #1, a
        Print #2, a
    Loop
q:  Close #1
    Close #2
End Sub

