Attribute VB_Name = "repmaker_h"
'
' 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(21) As Long, gEndPosD(21) As Long, _
       gStartPosH(21) As Long, gEndPosH(21) As Long, _
       gStartPosF(21) As Long, gEndPosF(21) As Long, _
       gStartPosDet As Long, gEndPosDet As Long, _
       gVal(21), 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(21, 15) '0-поле, 1-столбец, 2-нов.лист, 3-нов.страница, 4-символы гр., 5-скв.строки, 6-закрепление области
       
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, _
    st_tabstrip As String, DataFields(255) As DataField
       
Sub MakeReport()
Dim ws As Object, lcString As String, lnPos As Integer, c As Range, r As Range, _
    d1 As Date, d2 As Date, d As Date, i As Long, j As Long, _
    lcField As String, lcRepSheets As String, lnRepSheet As Integer, _
    lcStringOrder As String

    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

    lcAddParam = Trim(ThisWorkbook.Sheets(1).[f2].value)
    lcAddModule = GetStrParam(lcAddParam, 3)
    If lcAddModule <> "" Then
        Application.ThisWorkbook.VBProject.VBComponents.Import (repPath + "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

    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)
    lcWebFile = dbPath + lcWorkBook + ".htm"
    lcWebDir = lcWorkBook + ".files\"
    On Error GoTo Err_MkDir:
    If Dir(dbPath + lcWebDir, vbDirectory) <> "" Then
        Kill (dbPath + lcWebDir + "*.*")
        RmDir (dbPath + lcWebDir)
    End If
    MkDir (dbPath + lcWebDir)
Err_MkDir:
    On Error GoTo 0
    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
    Application.ActiveWorkbook.VBProject.VBComponents.Import (repPath + "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 (ws.Cells(gStartPosDet - 1, 1).value Like "^ Шапка*")
                gStartPosDet = gStartPosDet - 1
            Loop
            
            For i = 1 To rowsCount
                lcField = c.Offset(i - 1, 0).value
                lcString = lcString + IIf(lcString = "", "", ", ") + lcField
                j = 1
                Do While (Not UCase(groupProp(j, 0)) = UCase(lcField)) And (j <= groupCount)
                    j = j + 1
                Loop
                If j <= groupCount Then
                    ws.Rows(Trim(Str(gStartPosH(j))) + ":" + Trim(Str(gEndPosH(j) + 1))).Copy
                    wso.Rows(gStartPosDet).Insert Shift:=xlDown
                    gStartPosDet = gStartPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                    gEndPosDet = gEndPosDet + (gEndPosH(j) - gStartPosH(j) + 2)
                    ws.Rows(Trim(Str(gStartPosF(j))) + ":" + Trim(Str(gEndPosF(j) + 1))).Copy
                    wso.Rows(gEndPosDet + 1).Insert Shift:=xlDown
                    wso.[B1] = wso.[B1] + 1
                End If
            Next i
            If lcStringOrder <> "" Then
                lcString = lcString + IIf(lcString = "", "", ", ") + lcStringOrder
            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

    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.[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 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

    Call LoadNastr(wsd.[a1])

    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 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
                End If
                lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                WebSheets(WebSheetsCount).name = lcWebSheetName
                lcWebSheetFile = dbPath + lcWebDir + lcWebSheetName + ".htm"
                lcTableFile = dbPath + "c_table.htm"
'/html ------------------------------------------------------
                
                wso.Activate
                Set wsoRange = Range(Cells(1, 1), LastCell(Cells))
                Call RedefineFields(wsoRange)
                If lbStat Then
                    dTime2 = Time()
                    nTimeDiff = DateDiff("s", dTime1, dTime2)
                    dTime1 = dTime2
                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Подготовка формул")
                End If
                
'html -------------------------------------------------------
                Call AddStyle(wsoRange)
                
                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

'                Application.DisplayAlerts = False
    '*****************   Винокуров Андрей, 26.09.2002
                ' Добавляем дополнительные модули (ячейка H1)
'                i = 1
'                While GetStrParam(lcAddModuleFunc2, i) <> ""
'                    Application.ThisWorkbook.VBProject.VBComponents.Import (repPath + "MODULES\" + VBA.Trim(GetStrParam(lcAddModuleFunc2, i)))
'                    i = i + 1
'                Wend
                ' Выполняем дополнительные функции (ячейка I1)
'                i = 1
'                While GetStrParam(lcAddModuleFuncArg2, i) <> ""
'                    j = Application.Run(GetStrParam(lcAddModuleFuncArg2, i), GetStrParam(lcAddModuleFuncArg2, i + 1))
'                    i = i + 2
'                Wend
    '*****************   конец
'                If lbStat Then
'                    dTime2 = Time()
'                    nTimeDiff = DateDiff("s", dTime1, dTime2)
'                    dTime1 = dTime2
'                    Call PrintFile(lcLogFile, 1, "  " & nTimeDiff & " сек - Дополнительные действия")
'                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
            ' Создаем свою панель инструментов
            Call InitCBR
            lnPos = 1
            Application.StatusBar = "Подготовка листов (0%)"
            dTimeAllPage = Time()
            For Each ws In Application.ActiveWorkbook.Worksheets
                ws.Activate
                dTimePage = Time()
    '            If lbStat Then
    '                dTime2 = Time()
    '                nTimeDiff = DateDiff("s", dTime1, dTime2)
    '                dTime1 = dTime2
    '            End If
    '            Call SetLastRowsCount(lnLastRowsCount)
    '            If lbStat Then
    '                dTime2 = Time()
    '                nTimeDiff = DateDiff("s", dTime1, dTime2)
    '                dTime1 = dTime2
    '                Call PrintFile(lcLogFile, 1, "    " & nTimeDiff & " сек - Вставка разрыва страницы от висячих строк")
    '            End If
    '
                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 Integer
    Application.StatusBar = "Загрузка рабочих данных..."
    wsd.Activate
    Set startRange = wsd.Cells(DataStartRow - 1, 1)
    odbcDriver = GetODBCDriver()
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    odbcstr = "ODBC;" + _
        "Driver=" + odbcDriver + ";" + _
        "UID=admin;SourceType=DBF;" + _
        "DefaultDir=" + dbPath + "\;" + _
        "DBQ=" + dbPath + "\;" + _
        "SourceDB=" + dbPath + "\;"
    Set qt = wsd.QueryTables.Add(odbcstr, _
        startRange, dbSelect)
    qt.BackgroundQuery = False
    qt.FieldNames = True
    On Error GoTo Err1
    qt.Refresh
    On Error GoTo 0
    columnsCount = qt.ResultRange.Columns.count
    rowsCount = qt.ResultRange.Rows.count - 1
    If rowsCount <= 2 Then
        rowsCount = 0
        Do While Not IsEmptyRange(wsd.Range(Cells(rowsCount + DataStartRow, 1), Cells(rowsCount + DataStartRow, columnsCount)))
            rowsCount = rowsCount + 1
        Loop
    End If
    If rowsCount = 0 Then
        GoTo Err2
    End If
    ' Присвоение имен
    wsd.Parent.Names.Add name:="Data", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(rowsCount + DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add name:="DataFields", _
        RefersToR1C1:="=Данные!R" + Trim(Str(DataStartRow - 1)) + "C1:R" + Trim(Str(DataStartRow - 1)) + "C" + Trim(Str(columnsCount))
    wsd.Parent.Names.Add name:="CurRow", RefersToR1C1:="=Данные!R1C1"
    wsd.Parent.Names.Add name:="StartRow", RefersToR1C1:="=Данные!R1C2"
    wsd.Parent.Names.Add name:="EndRow", RefersToR1C1:="=Данные!R1C3"
    wsd.Parent.Names.Add name:="CurentGroup", RefersToR1C1:="=Данные!R1C4"
    wsd.Parent.Names.Add name:="GroupOrder", RefersToR1C1:="=Данные!R1C10"
    wsd.Parent.Names.Add name:="StartData", RefersToR1C1:="=Данные!R1C5"
    wsd.Parent.Names.Add name:="Start1", RefersToR1C1:="=Данные!R1C11"
    wsd.Parent.Names.Add name:="Start2", RefersToR1C1:="=Данные!R1C12"
    wsd.Parent.Names.Add name:="Start3", RefersToR1C1:="=Данные!R1C13"
    wsd.Parent.Names.Add name:="Start4", RefersToR1C1:="=Данные!R1C14"
    wsd.Parent.Names.Add name:="Start5", RefersToR1C1:="=Данные!R1C15"
    wsd.Parent.Names.Add name:="Start6", RefersToR1C1:="=Данные!R1C16"
    wsd.Parent.Names.Add name:="Start7", RefersToR1C1:="=Данные!R1C17"
    wsd.Parent.Names.Add name:="Start8", RefersToR1C1:="=Данные!R1C18"
    wsd.Parent.Names.Add name:="Start9", RefersToR1C1:="=Данные!R1C19"
    wsd.Parent.Names.Add name:="Start10", RefersToR1C1:="=Данные!R1C20"
    wsd.Parent.Names.Add name:="End1", RefersToR1C1:="=Данные!R1C31"
    wsd.Parent.Names.Add name:="End2", RefersToR1C1:="=Данные!R1C32"
    wsd.Parent.Names.Add name:="End3", RefersToR1C1:="=Данные!R1C33"
    wsd.Parent.Names.Add name:="End4", RefersToR1C1:="=Данные!R1C34"
    wsd.Parent.Names.Add name:="End5", RefersToR1C1:="=Данные!R1C35"
    wsd.Parent.Names.Add name:="End6", RefersToR1C1:="=Данные!R1C36"
    wsd.Parent.Names.Add name:="End7", RefersToR1C1:="=Данные!R1C37"
    wsd.Parent.Names.Add name:="End8", RefersToR1C1:="=Данные!R1C38"
    wsd.Parent.Names.Add name:="End9", RefersToR1C1:="=Данные!R1C39"
    wsd.Parent.Names.Add name:="End10", RefersToR1C1:="=Данные!R1C40"
    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, 31)
    wsd.[E1] = DataStartRow
    GoTo ExitProc
Err1:
    n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
    GoTo ExitProc
Err2:
    n = MsgBox("Нет данных для печати!", vbCritical + vbOKOnly, "Ошибка")
    Er = -1
ExitProc:
    Set startRange = Nothing
    Set qt = Nothing
End Sub

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

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

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


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

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


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

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

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

'    Application.StatusBar = "Преобразование полей..."
    For i = 1 To columnsCount
        fName = wsd.Cells(DataStartRow - 1, i).value   ' Имя поля
        wsd.Parent.Names.Add name:=fName, RefersToR1C1:="=Данные!R1C" + Trim(Str(50 + i))
        wsd.Cells(1, 50 + i).value = "-1"

        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 10
                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

        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 10
                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 Integer, c As Range, lB As Boolean
'    Application.StatusBar = "Подготовка к формированию отчета..."
    wsd.Select
    curPosD = DataStartRow
    gStartPosD(0) = DataStartRow
    groupCount = wso.[B1].value
    gEndPosH(0) = 0       ' Конечная строка шапки группы
    For i = 1 To groupCount
        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 ' Условие вывода
    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
        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
            groupProp(i, 13) = wso.Cells(gEndPosF(i) + 1, 8).value ' Условие вывода
        Loop
    Next i
    gEndPosD(0) = rowsCount + DataStartRow - 1
    Set c = Nothing
End Sub

Sub f1_2()
    Dim i As Integer
    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)

            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)

        ' Создание нового листа
        If (groupProp(curGr, 2) And Not nxlPages) Or curPosR > 32000 Then
            If groupProp(curGr, 7) Then
                groupProp(curGr, 7) = False
            Else
                
'html -------------------------------------------------------
                If SheetFieldColumn > 0 Then
                    cNewSheet = StrReplace(wsd.Cells(curPosD, SheetFieldColumn), " " , "")
                Else
                    cNewSheet = ""
                End If
                If cNewSheet <> WebSheets(WebSheetsCount).name Then

                    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 Then
                        lcWebSheetName = cNewSheet
                    End If
                    lcWebSheetName = StrReplace(lcWebSheetName, " ", "")
                    WebSheets(WebSheetsCount).name = lcWebSheetName
                    lcWebSheetFile = dbPath + lcWebDir + lcWebSheetName + ".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)
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
        End With

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

        If groupProp(curGr, 3) And Not nxlPages Then
            If groupProp(curGr, 8) Then
                groupProp(curGr, 8) = False
            Else
                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)
                    lcFormula = .FormulaLocal
                    .FormulaLocal = lcFormula
                    .Calculate
                    If .Value <> "" Then
                        bNotPrint = .Value
                    Else
                        bNotPrint = True
                    End If
                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)
            lcFormula = .FormulaLocal
            .FormulaLocal = lcFormula
            .Calculate
            If .Value <> "" Then
                bNotPrint = .Value
            Else
                bNotPrint = True
            End If
        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
    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 m1
    curRange.Calculate
' запись вычисленных ячеек в html

'html -------------------------------------------------------
    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 Integer  ' Ячейки исходного и сдублированного столбца,
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 Integer, 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 + 2, lnSkobka - lnStar - 2)
    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 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 Integer, 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 Integer
    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.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, , , xlByRows, xlPrevious).Row, r.Parent.Cells.Find("*", rLast, , , 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 Integer, lnNastrRow As Integer, lnNastrCol As Integer, qt As QueryTable, _
    n As Integer, lcName 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
        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)
                        .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 Integer
    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(cWhere As String, cWhat As String, cRepl As String) As String
Dim n As Integer
    n = 1
    Do
        n = InStr(n, cWhere, cWhat)
        If n > 0 Then
            cWhere = Mid(cWhere, 1, n - 1) + cRepl + Mid(cWhere, n + Len(cWhat))
            n = n + Len(cRepl)
        End If
    Loop While n <> 0
    StrReplace = cWhere
End Function

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

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

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

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

Sub 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 Integer, 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)
                    End If
                Else
                    c.FormulaLocal = "=" + Mid(fval, 4)
                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 = xlGeneral Or c.HorizontalAlignment = xlHAlignCenterAcrossSelection, "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")
                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 Integer, st As String, BotColontitul As String
    st = ""
    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, "")
    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")

    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) + "{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

    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>", "")
    WebSheets(WebSheetsCount).FitHeight = IIf(ActiveSheet.PageSetup.FitToPagesTall > 0, "<x:FitHeight>" + Trim(Str(ActiveSheet.PageSetup.FitToPagesTall)) + "</x:FitHeight>", "")
    WebSheets(WebSheetsCount).PaperSizeIndex = "<x:PaperSizeIndex>" + Trim(Str(ActiveSheet.PageSetup.PaperSize)) + "</x:PaperSizeIndex>"
    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>", "")

    lcSheetOptions = _
              IIf(WebSheets(WebSheetsCount).FitToPage <> "", "     " + WebSheets(WebSheetsCount).FitToPage + Chr(10), "") + _
              "     <x:Print>" + 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 Integer, 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 Integer, 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 Integer, 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 Integer, j As Integer, k As Integer, tr As Long, _
    rHeight As Double, st As String
    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
                cValue = r.Parent.Cells(i, r(1).column + wcs(i).wc(j).column - 1).Text
                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 r.Parent.Cells(i, r(1).column + wcs(i).wc(j).column - 1).value = 0 Then
                        cValue = ""
                    End If
                End If
                cValue = StrReplace(cValue, "&", "&amp;")
                cValue = StrReplace(cValue, ">", "&gt;")
                cValue = StrReplace(cValue, "<", "&lt;")
                cValue = StrReplace(cValue, """", "&quot;")
                cValue = StrReplace(cValue, Chr(10) + Chr(13), "<br>")
                cValue = StrReplace(cValue, Chr(10), "<br>")
                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 + " ", "") + _
                    ">" + cValue + "</td>" + Chr(10)
            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 Then
        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 Integer

    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 Integer
    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 Integer, 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=" + _
                  """" + WebSheets(i).name + ".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 Integer, 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=""" + WebSheets(i).name + ".htm""/>" + Chr(10)
    Next i
    st = st + "</xml>"
    GetWebFileList = st
End Function

Function GetWebMain() As String
Dim i As Integer, 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) + "/" + WebSheets(i).name + ".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) + "/" + WebSheets(i).name + ".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) + "/" + WebSheets(WebSheetsCount).name + ".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


