Attribute VB_Name = "Excel2DOS"
Public ReportRange As Range
Public CellBorders(1 To 8) As String, _
 ReportText() As String, _
AlignCells() As Integer, DoneCells() As Boolean
Public ReportData() As String, ReportBuffer() As String
Public Rows As Integer, Cols As Integer, ReportWidth As Integer
Public PageWidth As Integer
Public CellWidth() As Integer
Public DataString() As String
Public AdditionStrings() As String ' Cols * Rows, а не Rows*Cols, чтобы можно было менять через ReDim Preserve
Public InsertCount() As Integer
Public InsRowCount As Long
Public StepNumber  As Integer
Public HasLF As Boolean
Public HiddenRows() As Boolean
Public HiddenCols() As Boolean
Public UpperCase As Boolean

'Версия 2.1.7
'Удаляет CHR(10) из строк

'Версия 2.1.6
'При вызове через процедуру ExcelDos, по умолчанию создаются 
'файлы с расширением .txt, если в наименовании листа не присутствует "."

'Версия 2.1.5
'Исправлено форматирование одиночной ячейки - изменение ширины столбца
'затрагивает соседей

'Версия 2.1.4
'По умолчанию возвращает текст в верхнем регистре
'Вызов : ExcelDos("выходной_файл", [сохранять_регистр])


'Версия 2.1.3
'Увеличена скорость работы - содержимое листа читается только 1 раз в ReportBuffer

'Версия 2.1.2
'Сняты ограничения на шаблон:
'  1) левый верхний угол группы не должен быть скрытой ячейкой -
'  будет потеряно значение всей группы либо произойдет аварийный выход
'Список ограничений:
'  1) все символы учитываются, поэтому выравнивание с помощью пробелов или
'   лишние пробелы в ячейках могут нарушить форматирование

'Версия 2.1.1
'Исправлено форматирование групп - нет вылетов
'Версия 2.1.0
'Изменена работа c AdditionStrings для повышения быстродействия

Sub Demo0()
Dim t1 As Single, t2 As Single, t3 As Single, t4 As Single, i As Integer
  UpperCase = True
  Call Export
End Sub


Sub Demo()
Dim t1 As Single, t2 As Single, t3 As Single, t4 As Single, i As Integer
  UpperCase = True
  t3 = 0
  t4 = 0
  For i = 1 To 3
    t1 = Timer
    Call Export
    t2 = Timer
    t3 = t3 + t2 - t1
  Next i
  MsgBox (t3 / 3)
End Sub

Function ExcelDos(filePath As String, Optional SaveCase As Boolean = False) As Integer
Dim ws As Object, fName As String
  Set ws = Application.ActiveWorkbook.ActiveSheet
  Set ReportRange = ws.Range(ws.[a1], LastCell(ws.[a1]))
  UpperCase = Not SaveCase
  StepNumber = 1
  Call ReadData
  Call FormatReport

  StepNumber = 2
  Call ClearData
  Call ReadData
  Call FormatReport
  
  StepNumber = 3
  Call ClearData
  Call ReadData
  Call FormatReport
  fName = filePath + ws.Name
  fName = IIf(Instr(1, fName, ".") = 0, fName + ".txt", fName)
  Call PrintData(fName)
  ExcelDos = 1
End Function

Sub Export(Optional fName As String = "outFile", Optional WorkWs As Object = Nothing)
  Dim ws As Object

  If WorkWs Is Nothing Then
    Set ws = Application.ActiveWorkbook.ActiveSheet
  Else
    Set ws = WorkWs
  End If
  Set ReportRange = ws.Range(ws.[a1], LastCell(ws.[a1]))
  Call GetRealBorder(ReportRange)
 
  StepNumber = 1  'размер по горизонтали
  Call ReadData
  Call FormatReport

  StepNumber = 2  'размер по вертикали
  Call ClearData
  Call ReadData
  Call FormatReport

  StepNumber = 3  ' вывод данных
  Call ClearData
  Call ReadData
  Call FormatReport
  Call PrintData(fName)
End Sub

Sub ReadData()
  Dim i As Integer, j As Integer, k As Integer
  Dim HighDelims() As String, LowDelims() As String
  Dim DeltaLen As Integer
  
  If StepNumber = 1 Then
    Select Case ActiveSheet.PageSetup.Orientation
      Case xlLandscape
        PageWidth = 120 * ActiveSheet.PageSetup.FitToPagesWide
      Case xlPortrait
        PageWidth = 80 * ActiveSheet.PageSetup.FitToPagesWide
    End Select
  
    ReportWidth = ReportRange.Width
    Rows = ReportRange.Rows.Count
    Cols = ReportRange.Columns.Count ' + 1
    PageWidth = PageWidth - Cols * 2
  
    ReDim CellWidth(1 To Cols) As Integer
    ReDim HiddenRows(1 To Rows)
    ReDim HiddenCols(1 To Cols)
    
    For i = 1 To Rows
      HiddenRows(i) = (ReportRange.Cells(i, 1).EntireRow.Hidden)
    Next i
    For i = 1 To Cols
      HiddenCols(i) = ReportRange.Columns(i).Hidden Or (ReportRange.Cells(i, 1).Width = 0)
      If HiddenCols(i) Then
        CellWidth(i) = 0
      Else
        CellWidth(i) = PageWidth * ReportRange.Columns(i).Width / ReportWidth
        If CellWidth(i) <= 0 Then CellWidth(i) = 1
      End If
    Next i
  
    ReDim DataString(1 To Cols * 2 + 1) As String
    ReDim ReportData(1 To Rows * 2 + 1, 1 To Cols * 2 + 1)
    ReDim ReportBuffer(1 To Rows * 2 + 1, 1 To Cols * 2 + 1)
    ReDim ReportText(1 To Rows * 2 + 1, 1 To Cols * 2 + 1)
    ReDim AlignCells(1 To Rows, 1 To Cols)
  
    ReDim InsertCount(1 To Rows)
  End If
  
  ReDim DoneCells(1 To Rows, 1 To Cols)
  
  Select Case StepNumber
  Case 1
    ReDim HighDelims(1 To Cols * 2 + 1) As String
    ReDim LowDelims(1 To Cols * 2 + 1) As String
  
    For i = 1 To Cols * 2 + 1
      DataString(i) = " "
      HighDelims(i) = " "
      LowDelims(i) = " "
    Next i
  
    For i = 1 To Rows
      InsertCount(i) = 0
      For j = 1 To Cols * 2 + 1
        DataString(j) = " "
        HighDelims(j) = LowDelims(j)
        LowDelims(j) = " "
      Next j
      k = 2
      j = 1
      For j = 1 To Cols
      'границы
        Call GetCellBorders(ReportRange.Cells(i, j))
        HighDelims(k - 1) = CellBorders(1)
        HighDelims(k) = String(CellWidth(j), Left(CellBorders(2), 1))
        HighDelims(k + 1) = CellBorders(3)
        DataString(k - 1) = CellBorders(4)
        DataString(k + 1) = CellBorders(5)
        LowDelims(k - 1) = CellBorders(6)
        LowDelims(k) = String(CellWidth(j), Left(CellBorders(7), 1))
        LowDelims(k + 1) = CellBorders(8)
      
        DataString(k) = ConvertToOEM(ReportRange.Cells(i, j).Text)
      
        AlignCells(i, j) = ReportRange.Cells(i, j).HorizontalAlignment
        DoneCells(i, j) = False
      
        k = k + 2
      Next j
    
      For j = 1 To 2 * Cols + 1
        ReportText(2 * (i - 1) + 1, j) = HighDelims(j)
        ReportText(2 * i, j) = DataString(j)
      Next j
    Next i
  
    For j = 1 To 2 * Cols
      ReportText(2 * Rows + 1, j) = LowDelims(j)
    Next j
    
    For i = 1 To 2 * Rows + 1
      For j = 1 To 2 * Cols + 1
        If (i Mod 2 = 0) And (j Mod 2 = 0) Then
          ReportBuffer(i, j) = ReportText(i, j)
        Else
          ReportBuffer(i, j) = Left(ReportText(i, j), 1)
        End If
      Next j
    Next i
'**************************************************************
  Case 2
    For i = 1 To Rows
      InsertCount(i) = 0
      For j = 1 To Cols
        AlignCells(i, j) = ReportRange.Cells(i, j).HorizontalAlignment
        DoneCells(i, j) = False
      Next j
    Next i
    Dim ss As String
    For i = 1 To 2 * Rows + 1
      If (i Mod 2 = 0) Then
        For j = 1 To 2 * Cols + 1
          ReportText(i, j) = ReportBuffer(i, j)
        Next j
      Else
        For j = 1 To Cols
          ReportText(i, 2 * j - 1) = ReportBuffer(i, 2 * j - 1)
          ss = ReportBuffer(i, 2 * j)
          If ss <> "" Then ss = String(CellWidth(j), ss)
          ReportText(i, 2 * j) = ss
          ReportText(i, 2 * j + 1) = ReportBuffer(i, 2 * j + 1)
        Next j
      End If
    Next i
    
    For j = LBound(ReportText, 1) To UBound(ReportText, 1)
      For i = LBound(ReportText, 2) To UBound(ReportText, 2)
        ReportData(j, i) = ReportText(j, i)
      Next i
    Next j

'**************************************************************
  Case 3
    For j = LBound(ReportText, 1) To UBound(ReportText, 1)
      For i = LBound(ReportText, 2) To UBound(ReportText, 2)
        ReportText(j, i) = ReportData(j, i)
      Next i
    Next j
  End Select
End Sub

Sub FormatReport()
  Dim i As Integer, j As Integer
  Dim StrWidth As Integer, AlignStyle As Integer
  Dim k As Integer, l As Integer
  Dim ma As Range
  Dim CanHoriz As Boolean, CanVert As Boolean, CanTable As Boolean
  Dim DeltaLen As Integer
      
  InsRowCount = 0
  For i = 1 To Rows
    For j = 1 To Cols
      If Not DoneCells(i, j) Then
        StrWidth = CellWidth(j)
        AlignStyle = AlignCells(i, j)
        k = 2 * i
        l = 2 * j
        Set ma = ReportRange.Cells(i, j).MergeArea
        If ReportRange.Cells(i, j).MergeCells Then 'часть группы
          Call FormatMerge(ma, i, j, AlignStyle)
        Else
          'не группа
          If HiddenCols(j) Then GoTo NextJ
          If InStr(1, ReportText(k, l), Chr(10)) > 0 Then HasLF = True Else HasLF = False
          If (Len(ReportText(k, l)) > StrWidth) Or HasLF Then
          'требуется расширить
            'пытаемся раздвинуть по горизонтали
            CanHoriz = (AlignStyle = xlRight And ReportText(k, l - 1) = " ") _
              Or (AlignStyle = xlCenter And (ReportText(k, l - 1) = " " Or ReportText(k, l + 1) = " ")) _
            Or (AlignStyle <> xlRight And AlignStyle <> xlLeft And ReportText(k, l + 1) = " ")
            
            Dim Width1 As Integer
            If CanHoriz Then
              Select Case AlignStyle
                Case xlRight
                  If l = 2 Then
                    CanHoriz = False 'некуда
                  Else
                    l2 = l - 2
                    Width1 = CellWidth(l / 2) + 1
                    Do While (l2 > 0) And ReportText(k, l2 + 1) = " "
                      Width1 = Width1 + CellWidth(l2 / 2) + 1
                      l2 = l2 - 2
                    Loop
                    If Width1 < Len(ReportText(k, l)) Then CanHoriz = False 'не влезет
                  End If
              End Select
            End If
            
            CanVert = (Not CanHoriz) And Left(ReportText(2 * i + 1, 2 * j), 1) = " "
            CanVert = CanVert Or HasLF Or ReportRange(i, j).WrapText
            If CanVert Then CanHoriz = False
            
            If CanHoriz Then
              Select Case AlignStyle
                Case xlRight
                  Call FormatHorisRight(i, j, k, l, StrWidth, AlignStyle)
                Case xlCenter
                  Call FormatHorisCenter(i, j, k, l, StrWidth, AlignStyle)
                Case Else 'считаем, что DEFAULT=xlLeft
                  Call FormatHorisLeft(i, j, k, l, StrWidth, AlignStyle)
              End Select
            End If 'по горизонтали
            If CanVert Then 'по вертикали
              Call FormatVert(i, k, l, StrWidth, AlignStyle)
            End If
            If Not (CanHoriz Or CanVert) Then
               DeltaLen = Len(ReportText(2 * i, 2 * j)) - CellWidth(j)
               If (DeltaLen > 0) And StepNumber = 1 Then
                 CellWidth(j) = CellWidth(j) + DeltaLen
               End If
            End If
          End If 'подгон длины
          ReportText(k, 2 * j) = FormatString(ReportText(k, 2 * j), StrWidth, AlignStyle)
NextJ:
          DoneCells(i, j) = True
        End If 'не группа
      End If

    Next j
  Next i
  
End Sub


Function LastCell(r As Range) As Range
Dim rLast As Range
    Set rLast = r.Cells.SpecialCells(xlCellTypeLastCell)
'    If rLast.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 LastCell = rLast
End Function

Sub GetCellBorders(r As Range)
'    --------------------
'   |  LT  |  T   |  RT  |     179  - і       193 - Б      197  - Е
'   |      |      |      |
'   |------|------|------|     180  - ґ       194 - В      217  - Щ
'   |  L   | Curr.|  R   |
'   |      | Cell |      |     191  - ї       195 - Г      218  - Ъ
'   |------|------|------|
'   |  LB  |  B   |  RB  |     192  - А       196 - Д
'   |      |      |      |
'    --------------------
'
'

  Dim i As Integer, Left As Boolean, Right As Boolean, Top As Boolean, Bottom As Boolean
  Dim LTRight As Boolean, LTBottom As Boolean
  Dim TLeft As Boolean, TBottom As Boolean, TRight As Boolean
  Dim RTLeft As Boolean, RTBottom As Boolean
  Dim LTop As Boolean, LRigth As Boolean, LBottom As Boolean
  Dim RTop As Boolean, RLeft As Boolean, RBottom As Boolean
  Dim LBTop As Boolean, LBRight As Boolean
  Dim BLeft As Boolean, BTop As Boolean, BRight As Boolean
  Dim RBLeft As Boolean, RBTop As Boolean
  
  Dim LLine As Boolean, RLine As Boolean, TLine As Boolean, BLine As Boolean
  
  Dim CurRow, CurCol
  
  CurRow = r.Row
  CurCol = r.Column
  
  For i = 1 To 8
    CellBorders(i) = " "
  Next i
  
  If r.Row = 1 Then
    LTRight = False
    LTBottom = False
    TLeft = False
    TBottom = False
    TRight = False
    RTLeft = False
    RTBottom = False
  Else
    TLeft = r.Parent.Cells(CurRow - 1, CurCol).Borders(xlEdgeLeft).LineStyle <> xlNone
    TBottom = r.Parent.Cells(CurRow - 1, CurCol).Borders(xlEdgeBottom).LineStyle <> xlNone
    TRight = r.Parent.Cells(CurRow - 1, CurCol).Borders(xlEdgeRight).LineStyle <> xlNone
    RTLeft = r.Parent.Cells(CurRow - 1, CurCol + 1).Borders(xlEdgeLeft).LineStyle <> xlNone
    RTBottom = r.Parent.Cells(CurRow - 1, CurCol + 1).Borders(xlEdgeBottom).LineStyle <> xlNone
  End If
  
  If r.Column = 1 Then
    LTRight = False
    LTBottom = False
    LTop = False
    LRight = False
    LBottom = False
    LBTop = False
    LBRight = False
  Else
    LTop = r.Parent.Cells(CurRow, CurCol - 1).Borders(xlEdgeTop).LineStyle <> xlNone
    LRight = r.Parent.Cells(CurRow, CurCol - 1).Borders(xlEdgeRight).LineStyle <> xlNone
    LBottom = r.Parent.Cells(CurRow, CurCol - 1).Borders(xlEdgeBottom).LineStyle <> xlNone
    LBTop = r.Parent.Cells(CurRow + 1, CurCol - 1).Borders(xlEdgeTop).LineStyle <> xlNone
    LBRight = r.Parent.Cells(CurRow + 1, CurCol - 1).Borders(xlEdgeRight).LineStyle <> xlNone
  End If
  
  If r.Column <> 1 And r.Row <> 1 Then
    LTBottom = r.Parent.Cells(CurRow - 1, CurCol - 1).Borders(xlEdgeBottom).LineStyle <> xlNone
    LTRight = r.Parent.Cells(CurRow - 1, CurCol - 1).Borders(xlEdgeRight).LineStyle <> xlNone
  End If
  
  RTop = r.Parent.Cells(CurRow, CurCol + 1).Borders(xlEdgeTop).LineStyle <> xlNone
  RLeft = r.Parent.Cells(CurRow, CurCol + 1).Borders(xlEdgeLeft).LineStyle <> xlNone
  RBottom = r.Parent.Cells(CurRow, CurCol + 1).Borders(xlEdgeBottom).LineStyle <> xlNone
  RBTop = r.Parent.Cells(CurRow + 1, CurCol + 1).Borders(xlEdgeTop).LineStyle <> xlNone
  RBLeft = r.Parent.Cells(CurRow + 1, CurCol + 1).Borders(xlEdgeLeft).LineStyle <> xlNone
  
  BTop = r.Parent.Cells(CurRow + 1, CurCol).Borders(xlEdgeTop).LineStyle <> xlNone
  BLeft = r.Parent.Cells(CurRow + 1, CurCol).Borders(xlEdgeLeft).LineStyle <> xlNone
  BRight = r.Parent.Cells(CurRow + 1, CurCol).Borders(xlEdgeRight).LineStyle <> xlNone
  
  Left = r.Borders(xlEdgeLeft).LineStyle <> xlNone
  Right = r.Borders(xlEdgeRight).LineStyle <> xlNone
  Top = r.Borders(xlEdgeTop).LineStyle <> xlNone
  Bottom = r.Borders(xlEdgeBottom).LineStyle <> xlNone
 
'left top
  BLine = LRight Or Left
  TLine = LTRight Or TLeft
  LLine = LTBottom Or LTop
  RLine = TBottom Or Top
  
  If Not (BLine Or TLine Or LLine Or RLine) Then
    CellBorders(1) = " "
    GoTo Next1
  End If
  If BLine And Not (LLine Or RLine) Then
    CellBorders(1) = Chr(179)
      GoTo Next1
  End If
  If RLine And Not (BLine Or TLine) Then
    CellBorders(1) = Chr(196)
      GoTo Next1
  End If
  If Not LLine And RLine And Not TLine And BLine Then
    CellBorders(1) = Chr(218)
    GoTo Next1
  End If
  If Not LLine And RLine And TLine And Not BLine Then
    CellBorders(1) = Chr(192)
    GoTo Next1
  End If
  If Not LLine And RLine And TLine And BLine Then
    CellBorders(1) = Chr(195)
    GoTo Next1
  End If
  If LLine And Not RLine And Not TLine And BLine Then
    CellBorders(1) = Chr(191)
      GoTo Next1
  End If
  If LLine And Not RLine And TLine And Not BLine Then
    CellBorders(1) = Chr(217)
    GoTo Next1
  End If
  If LLine And Not RLine And TLine And BLine Then
    CellBorders(1) = Chr(180)
    GoTo Next1
  End If
  If LLine And RLine And Not TLine And BLine Then
    CellBorders(1) = Chr(194)
      GoTo Next1
  End If
  If LLine And RLine And TLine And Not BLine Then
    CellBorders(1) = Chr(193)
    GoTo Next1
  End If
  If LLine And RLine And TLine And BLine Then CellBorders(1) = Chr(197)

Next1:
'top
  If RLine Then CellBorders(2) = Chr(196) Else CellBorders(2) = " "
'right top
  BLine = Right Or RLeft
  TLine = RTLeft Or TRight
  LLine = Top Or TBottom
  RLine = RTBottom Or RTop
  
  If Not (BLine Or TLine Or LLine Or RLine) Then
    CellBorders(3) = " "
    GoTo Next2
  End If
  If BLine And Not (LLine Or RLine) Then
    CellBorders(3) = Chr(179)
    GoTo Next2
  End If
  If LLine And Not (BLine Or TLine) Then
    CellBorders(3) = Chr(196)
    GoTo Next2
  End If
  If Not LLine And RLine And Not TLine And BLine Then
    CellBorders(3) = Chr(218)
    GoTo Next2
  End If
  If Not LLine And RLine And TLine And Not BLine Then
    CellBorders(3) = Chr(192)
    GoTo Next2
  End If
  If Not LLine And RLine And TLine And BLine Then
    CellBorders(3) = Chr(195)
    GoTo Next2
  End If
  If LLine And Not RLine And Not TLine And BLine Then
    CellBorders(3) = Chr(191)
    GoTo Next2
  End If
  If LLine And Not RLine And TLine And Not BLine Then
    CellBorders(3) = Chr(217)
    GoTo Next2
  End If
  If LLine And Not RLine And TLine And BLine Then
    CellBorders(3) = Chr(180)
    GoTo Next2
  End If
  If LLine And RLine And Not TLine And BLine Then
    CellBorders(3) = Chr(194)
    GoTo Next2
  End If
  If LLine And RLine And TLine And Not BLine Then
    CellBorders(3) = Chr(193)
    GoTo Next2
  End If
  If LLine And RLine And TLine And BLine Then CellBorders(3) = Chr(197)

Next2:
'left
  If LRight Or Left Then CellBorders(4) = Chr(179) Else CellBorders(4) = " "
  
'Right
  If RLeft Or Right Then CellBorders(5) = Chr(179) Else CellBorders(5) = " "

'left bottom
  LLine = LBottom Or LBTop
  RLine = Bottom Or BTop
  TLine = LRight Or Left
  BLine = LBRight Or BLeft
  If Not (BLine Or TLine Or LLine Or RLine) Then
    CellBorders(6) = " "
    GoTo Next3
  End If
  If BLine And Not (LLine Or RLine) Then
    CellBorders(6) = Chr(179)
    GoTo Next3
  End If
  If RLine And Not (BLine Or TLine) Then
    CellBorders(6) = Chr(196)
    GoTo Next3
  End If
  If Not LLine And RLine And Not TLine And BLine Then
    CellBorders(6) = Chr(218)
    GoTo Next3
  End If
  If Not LLine And RLine And TLine And Not BLine Then
    CellBorders(6) = Chr(192)
    GoTo Next3
  End If
  If Not LLine And RLine And TLine And BLine Then
    CellBorders(6) = Chr(195)
    GoTo Next3
  End If
  If LLine And Not RLine And Not TLine And BLine Then
    CellBorders(6) = Chr(191)
      GoTo Next3
  End If
  If LLine And Not RLine And TLine And Not BLine Then
    CellBorders(6) = Chr(217)
    GoTo Next3
  End If
  If LLine And Not RLine And TLine And BLine Then
    CellBorders(6) = Chr(180)
    GoTo Next3
  End If
  If LLine And RLine And Not TLine And BLine Then
    CellBorders(6) = Chr(194)
    GoTo Next3
  End If
  If LLine And RLine And TLine And Not BLine Then
    CellBorders(6) = Chr(193)
      GoTo Next3
  End If
  If LLine And RLine And TLine And BLine Then CellBorders(6) = Chr(197)
  
Next3:
'bottom
  If RLine Then CellBorders(7) = Chr(196) Else CellBorders(7) = " "
  
'right bottom
  LLine = Bottom Or BTop
  RLine = RBottom Or RBTop
  TLine = Right Or RLeft
  BLine = BRight Or RBLeft
  If Not (BLine Or TLine Or LLine Or RLine) Then
    CellBorders(8) = " "
    GoTo Next4
  End If
  If BLine And Not (LLine Or RLine) Then
    CellBorders(8) = Chr(179)
    GoTo Next4
  End If
  If LLine And Not (BLine Or TLine) Then
    CellBorders(8) = Chr(196)
    GoTo Next4
  End If
  If Not LLine And RLine And Not TLine And BLine Then
    CellBorders(8) = Chr(218)
    GoTo Next4
  End If
  If Not LLine And RLine And TLine And Not BLine Then
    CellBorders(8) = Chr(192)
    GoTo Next4
  End If
  If Not LLine And RLine And TLine And BLine Then
    CellBorders(8) = Chr(195)
    GoTo Next4
  End If
  If LLine And Not RLine And Not TLine And BLine Then
    CellBorders(8) = Chr(191)
      GoTo Next4
  End If
  If LLine And Not RLine And TLine And Not BLine Then
    CellBorders(8) = Chr(217)
    GoTo Next4
  End If
  If LLine And Not RLine And TLine And BLine Then
    CellBorders(8) = Chr(180)
    GoTo Next4
  End If
  If LLine And RLine And Not TLine And BLine Then
    CellBorders(8) = Chr(194)
    GoTo Next4
  End If
  If LLine And RLine And TLine And Not BLine Then
    CellBorders(8) = Chr(193)
    GoTo Next4
  End If
  If LLine And RLine And TLine And BLine Then CellBorders(8) = Chr(197)
Next4:
End Sub


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

Function FormatString(s As String, StrLen As Integer, FormatStyle As Integer) As String
  Dim DeltaLen As Integer, TmpStr As String, i As Integer, j As Integer
  
  If (Len(s) < StrLen) Then
    DeltaLen = StrLen - Len(s)
    Select Case FormatStyle
      Case xlHAlignLeft
        FormatString = s + Space(DeltaLen)
      Case xlHAlignRight
        FormatString = Space(DeltaLen) + s
      Case xlHAlignCenter
        If (DeltaLen Mod 2) = 0 Then
          FormatString = Space(DeltaLen / 2) + s + Space(DeltaLen / 2)
        Else
          FormatString = Space((DeltaLen - 1) / 2) + s + Space((DeltaLen - 1) / 2 + 1)
        End If
      Case xlHAlignFill
        i = StrLen \ Len(s)
        FormatString = ""
        For j = 1 To i
          FormatString = FormatString + s
        Next j
        DeltaLen = StrLen - Len(FormatString)
        FormatString = FormatString + Space(DeltaLen)
        
      Case Else
        If IsNumeric(s) Then
          FormatString = Space(DeltaLen) + s
        Else
          FormatString = s + Space(DeltaLen)
        End If
    End Select
  Else
    FormatString = s
  End If
End Function

Sub PrintData(fName As String)
  Dim i As Integer, j As Integer, k As Integer
  Dim TmpPos As Integer
  Dim TmpStr As String
  
  Dim FileNumber
  If fName = "" Then fName = "outFile"
  'Файл
  FileNumber = FreeFile
  Open fName For Output As FileNumber
  For i = 1 To 2 * Rows + 1
    For j = 1 To 2 * Cols + 1
      If (j Mod 2) = 1 Then DataString(j) = ReportText(i, j)
      If (j Mod 2) = 0 Then
        If Not HiddenCols(j / 2) Then
          DataString(j) = ReportText(i, j)
        Else
          DataString(j) = ""
          If DataString(j - 1) <> " " And DataString(j - 1) <> Chr(196) And ReportText(i, j + 1) <> " " Then
            'две границы - жертвуем левой
            DataString(j - 1) = ""
          Else
          End If
        End If
      End If
    Next j
    TmpStr = JOIN97(DataString, "")
    If (i Mod 2) = 1 Then 'строка псевдографики
      'пустые строки не выводим
      If Len(LTrim(TmpStr)) > 0 Then Print #FileNumber, TmpStr
    End If
    If (i Mod 2) = 0 Then 'строка данных
      If Not HiddenRows(i / 2) Then Print #FileNumber, TmpStr
    End If
    If (i Mod 2) = 0 Then 'строка данных
      If Not HiddenRows(i / 2) Then
        If InsertCount(i / 2) > 0 Then 'выводим дополнительные строки
          TmpPos = CurrentInsPos(i / 2)
          For k = 1 To InsertCount(i / 2)
            For j = 1 To 2 * Cols + 1
              If (j Mod 2) = 1 Then DataString(j) = AdditionStrings(j, TmpPos)
              If (j Mod 2) = 0 Then
                If Not HiddenCols(j / 2) Then
                  DataString(j) = AdditionStrings(j, TmpPos)
                Else
                  DataString(j) = ""
                  If DataString(j - 1) <> " " And DataString(j - 1) <> Chr(196) And AdditionStrings(j + 1, TmpPos) <> " " Then
                    'две границы - жертвуем левой
                    DataString(j - 1) = ""
                  End If
                End If
              End If
            Next j
            TmpPos = TmpPos + 1
            TmpStr = JOIN97(DataString, "")
            Print #FileNumber, TmpStr
          Next k
        End If
      End If
    End If
  Next i
  
  Close FileNumber
End Sub
Sub ClearData()
  Dim i As Integer, j As Integer, k As Integer
  Dim TmpPos As Integer
  Dim TmpStr As String
  Dim TmpLen() As Integer
  
  ReDim TmpLen(1 To 2 * Cols + 1)
  For i = 1 To 2 * Rows + 1
    For j = 1 To 2 * Cols + 1
      TmpLen(j) = Len(ReportText(i, j))
      ReportText(i, j) = ""
    Next j
    If (i Mod 2) = 0 Then 'строка данных
      If InsertCount(i / 2) > 0 Then 'дополнительные строки
        TmpPos = CurrentInsPos(i / 2)
        For k = 1 To InsertCount(i / 2)
          For j = 1 To Cols
            If StepNumber < 3 Then
              AdditionStrings(j * 2, TmpPos) = ""
              AdditionStrings(j * 2 - 1, TmpPos) = ""
              AdditionStrings(j * 2 + 1, TmpPos) = ""
            Else
              AdditionStrings(j * 2, TmpPos) = Space(TmpLen(2 * j))
              If TmpLen(2 * j - 1) = 0 Then AdditionStrings(j * 2 - 1, TmpPos) = ""
              If TmpLen(2 * j + 1) = 0 Then AdditionStrings(j * 2 + 1, TmpPos) = ""
            End If
          Next j
          TmpPos = TmpPos + 1
        Next k
      End If
    End If
  Next i
  For i = 1 To Rows
    For j = 1 To Cols
      DoneCells(i, j) = False
    Next j
  Next i
End Sub

Sub insertRow(num As Integer)
  Dim i As Integer, j As Integer
  InsertCount(num) = InsertCount(num) + 1
  If InsRowCount = 0 Then
    ReDim AdditionStrings(0 To Cols * 2 + 1, 1 To 1)
  Else
    ReDim Preserve AdditionStrings(0 To Cols * 2 + 1, 1 To InsRowCount + 1)
  End If
  j = 2
  InsRowCount = InsRowCount + 1
  While j < Cols * 2 + 1
    If ReportText(2 * num, j - 1) <> "" Then
      AdditionStrings(j - 1, InsRowCount) = ReportText(2 * num, j - 1)
    Else
      AdditionStrings(j - 1, InsRowCount) = " "
    End If
    AdditionStrings(j, InsRowCount) = Space(CellWidth(j / 2))
    If ReportText(2 * num, j + 1) = "" Then
      AdditionStrings(j + 1, InsRowCount) = " "
    Else
      AdditionStrings(j + 1, InsRowCount) = ReportText(2 * num, j + 1)
    End If
    j = j + 2
  Wend
  AdditionStrings(0, InsRowCount) = Str(num)
End Sub

Function CurrentInsPos(num As Integer) As Integer
  Dim i As Integer, sm As Integer
  sm = 1
  For i = 1 To num - 1
    sm = sm + InsertCount(i)
  Next i
  CurrentInsPos = sm
End Function

Sub FormatHorisRight(i As Integer, j As Integer, k As Integer, l As Integer, ByRef StrWidth As Integer, AlignStyle As Integer)
  Dim DeltaLen As Integer
  Dim StartL As Integer
  Dim CellsINStr As Integer, n As Integer
  
  StartL = l
  CellsINStr = 1
  If HiddenCols(j) Then Exit Sub
  
  l = l - 2
  If l > 0 Then
    Do While _
    (StrWidth < Len(ReportText(2 * i, 2 * j)) _
    And (Trim(ReportText(2 * i, l)) = "") _
    And (ReportText(2 * i, l + 1) = " ")) _
    And (ReportText(2 * i, l) <> "")
'   Не хватает длины
'   AND сосед слева пустой
'   AND нет границы между текущей ячейкой и соседом
'   AND сосед слева не обработан раньше как часть блока/скрытый столбец
'      If Not DoneCells(i, l / 2) Then
'        If CellWidth(l / 2) > 0 Then StrWidth = StrWidth + CellWidth(l / 2) + 1
        StrWidth = StrWidth + CellWidth(l / 2) + 1
        ReportText(k, l) = ""
        ReportText(k, l + 1) = ""
        DoneCells(i, l / 2) = True
        CellsINStr = CellsINStr + 1
'      Else
'        Exit Do
'      End If
      l = l - 2
      If l <= 0 Then Exit Do
    Loop
  End If
  DeltaLen = Len(ReportText(2 * i, 2 * j)) - StrWidth
  If (DeltaLen > 0) And StepNumber = 1 Then
    If CellsINStr = 1 Then
      CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
    Else
      While DeltaLen > 0
        For n = 0 To CellsINStr - 1
          CellWidth(StartL / 2 - n) = CellWidth(StartL / 2 - n) + 1
          DeltaLen = DeltaLen - 1
          If DeltaLen = 0 Then Exit For
        Next n
      Wend
    End If
  End If
End Sub

Sub FormatHorisCenter(i As Integer, j As Integer, k As Integer, l As Integer, ByRef StrWidth As Integer, AlignStyle As Integer)
  Dim ll As Integer, mm As Integer, DeltaLen As Integer
  Dim LtBorder As Boolean, RtBorder As Boolean
  Dim NoMorePlace As Boolean
  Dim StartL As Integer
  Dim CellsINStr As Integer, n As Integer
  Dim CellsINStrL As Integer, CellsINStrR As Integer
  
  StartL = l
  CellsINStr = 1
  CellsINStrL = 0
  CellsINStrR = 0
  If HiddenCols(j) Then Exit Sub
  
  NoMorePlace = (ReportText(2 * i, l - 1) <> " ") And (ReportText(2 * i, l + 1) <> " ")
  ll = l - 2
  mm = l + 2
  Do While (StrWidth < Len(ReportText(2 * i, 2 * j)) And Not NoMorePlace)
    If ll > 0 Then
      If ReportText(k, ll + 1) = " " And Trim(ReportText(k, ll)) = "" Then
'         If Not DoneCells(i, ll / 2) Then
'           If CellWidth(ll / 2) > 0 Then StrWidth = StrWidth + CellWidth(ll / 2) + 1
           StrWidth = StrWidth + CellWidth(ll / 2) + 1
           ReportText(k, ll) = ""
           ReportText(k, ll + 1) = ""
           DoneCells(i, ll / 2) = True
           CellsINStr = CellsINStr + 1
           CellsINStrL = CellsINStrL + 1
'         Else
'           ll = 0
'         End If
      End If
    End If
                
    If (StrWidth < Len(ReportText(2 * i, 2 * j))) And (mm <= Cols * 2) Then
      If ReportText(k, mm - 1) = " " And ReportText(k, mm) = "" Then
        If Not DoneCells(i, mm / 2) Then
          If CellWidth(mm / 2) > 0 Then StrWidth = StrWidth + CellWidth(mm / 2) + 1
          ReportText(k, mm) = ""
          ReportText(k, mm - 1) = ""
          DoneCells(i, mm / 2) = True
          CellsINStrR = CellsINStrR + 1
          CellsINStr = CellsINStr + 1
        Else
          mm = (Cols + 1) * 2
        End If
      End If
    End If
                    
    If ll > 0 Then ll = ll - 2
    If mm < Cols * 2 Then mm = mm + 2
                    
    If ll > 0 Then LtBorder = (ReportText(k, ll + 1) = " ") Else LtBorder = True
    If mm < Cols * 2 Then RtBorder = (ReportText(k, mm - 1) = " ") Else RtBorder = True
    NoMorePlace = LtBorder And RtBorder
  Loop
  DeltaLen = Len(ReportText(2 * i, 2 * j)) - StrWidth
  If (DeltaLen > 0) And StepNumber = 1 Then
    If CellsINStr = 1 Then
      CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
    Else
      While DeltaLen > 0
        CellWidth(StartL / 2) = CellWidth(StartL / 2) + 1
        For n = 1 To CellsINStrL
          CellWidth(StartL / 2 - n) = CellWidth(StartL / 2 - n) + 1
        Next n
        For n = 1 To CellsINStrR
          CellWidth(StartL / 2 + n) = CellWidth(StartL / 2 + n) + 1
        Next n
        DeltaLen = DeltaLen - CellsINStrR - CellsINStrL - 1
      Wend
    End If
  End If
End Sub
Sub FormatHorisLeft(i As Integer, j As Integer, k As Integer, l As Integer, ByRef StrWidth As Integer, AlignStyle As Integer)
Dim DeltaLen As Integer, StartL As Integer
Dim CellsINStr As Integer, n As Integer

  StartL = l
  CellsINStr = 1
  If HiddenCols(j) Then Exit Sub
  
  If (ReportText(k, l + 1) = " ") Then
    l = l + 2
    If l <= 2 * Cols Then
      Do While (StrWidth < Len(ReportText(2 * i, 2 * j)) _
      And (ReportText(2 * i, l)) = "" _
      And (ReportText(2 * i, l - 1) = " ") _
      And Not ReportRange.Cells(i, l / 2).MergeCells _
      And Not DoneCells(i, l / 2))
'        If CellWidth(l / 2) > 0 Then StrWidth = StrWidth + CellWidth(l / 2) + 1
        StrWidth = StrWidth + CellWidth(l / 2) + 1
        ReportText(k, l) = ""
        ReportText(k, l - 1) = ""
        DoneCells(i, l / 2) = True
        CellsINStr = CellsINStr + 1
        l = l + 2
        If l > 2 * Cols Then Exit Do
      Loop
    End If
  End If
  DeltaLen = Len(ReportText(2 * i, 2 * j)) - StrWidth
  If (DeltaLen > 0) And StepNumber = 1 Then
    If CellsINStr = 1 Then
      CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
    Else
      While DeltaLen > 0
        For n = 0 To CellsINStr - 1
          CellWidth(StartL / 2 + n) = CellWidth(StartL / 2 + n) + 1
          DeltaLen = DeltaLen - 1
          If DeltaLen = 0 Then Exit For
        Next n
      Wend
    End If
  End If
End Sub
Sub FormatVert(i As Integer, k As Integer, l As Integer, ByRef StrWidth As Integer, AlignStyle As Integer)
  Dim TmpCnt As Integer
  Dim jj As Integer
  Dim DeltaLen As Integer
  Dim tt As Integer, ttc As Integer
  Dim TmpPos As Integer, TmpStr As String, TmpStr2 As String, NewStrings() As String
  
  ReDim NewStrings(1 To 1)
  StrCnt = 1
  TmpStr = ReportText(k, l)
  If (Len(TmpStr) > StrWidth) Or HasLF Then
    'рвем строку на части
    Do While Len(TmpStr) > 0
      Call splitline(TmpStr, TmpStr2, StrWidth)
      If Len(TmpStr2) > 0 Then
        ReDim Preserve NewStrings(1 To StrCnt + 1)
        StrCnt = StrCnt + 1
        NewStrings(StrCnt) = FormatString(TmpStr2, StrWidth, AlignStyle)
      End If
    Loop
  Else
    ReDim Preserve NewStrings(1 To 2)
    NewStrings(2) = FormatString(TmpStr, StrWidth, AlignStyle)
    StrCnt = 2
  End If
  
  TmpCnt = UBound(NewStrings) - 2
  If InsertCount(i) < TmpCnt Then
    ttc = TmpCnt - InsertCount(i)
    For tt = 1 To ttc
      Call insertRow(i)
    Next tt
  End If
  ReportText(k, l) = NewStrings(2)
  TmpPos = CurrentInsPos(i)
  For tt = 0 To TmpCnt - 1
    AdditionStrings(l, TmpPos + tt) = NewStrings(3 + tt)
  Next tt
End Sub


Sub FormatMerge(ma As Range, i As Integer, j As Integer, AlignStyle As Integer)
  Dim RowCnt As Integer, ColCnt As Integer, InsPos As Integer
  Dim k As Integer, l As Integer, StrWidth As Integer, MaxSize As Integer, CurSize As Integer
  Dim m As Integer, n
  Dim NewStrings() As String, TmpStr As String, TmpStr2 As String
  Dim StrCnt As Integer '=UBound(NewStrings)
  Dim RealStrCnt As Integer
  Dim StartRow As Integer, LineStep As Integer
  Dim DeltaLines As Integer
  Dim BufStr() As String
  
  ReDim NewStrings(1 To 1)
  
  RowCnt = ma.Rows.Count
  ColCnt = ma.Columns.Count
  k = i * 2
  l = j * 2
  StrCnt = 1
  RealStrCnt = 2 * RowCnt - 1 + InsertCount(i) 'внутренние строки разделителей - под текст
  
  For m = 0 To RowCnt - 1
    For n = 0 To ColCnt - 1
      DoneCells(i + m, j + n) = True
    Next n
  Next m
  
  TmpStr = ReportText(k, l)
  CurSize = Len(TmpStr)
  StrWidth = 0
  For m = 0 To ColCnt - 1
    StrWidth = StrWidth + CellWidth(j + m) + 1
  Next m
  If StrWidth = 1 Then Exit Sub 'только невидимые столбцы
  If StrWidth > 0 Then StrWidth = StrWidth - 1
  MaxSize = StrWidth * (2 * RowCnt - 1)
  
  'вертикальные границы
  For m = 1 To (RowCnt * 2) - 2
    Select Case Asc(Left(ReportText(k + m, l - 1), 1))
      Case 192
        ReportText(k + m, l - 1) = Chr(179)
      Case 193
        ReportText(k + m, l - 1) = Chr(217)
      Case 194
        ReportText(k + m, l - 1) = Chr(191)
      Case 195
        ReportText(k + m, l - 1) = Chr(179)
      Case 197
        ReportText(k + m, l - 1) = Chr(180)
      Case 218
        ReportText(k + m, l - 1) = Chr(179)
    End Select
    Select Case Asc(Left(ReportText(k + m, l + ColCnt * 2 - 1), 1))
      Case 180
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(179)
      Case 191
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(179)
      Case 193
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(192)
      Case 194
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(218)
      Case 197
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(195)
      Case 217
        ReportText(k + m, l + ColCnt * 2 - 1) = Chr(179)
    End Select
  Next m
  
  If Len(TmpStr) > StrWidth Then
    'рвем строку на части
    Do While Len(TmpStr) > 0
      Call splitline(TmpStr, TmpStr2, StrWidth)
      If Len(TmpStr2) > 0 Then
        ReDim Preserve NewStrings(1 To StrCnt + 1)
        StrCnt = StrCnt + 1
        NewStrings(StrCnt) = FormatString(TmpStr2, StrWidth, AlignStyle)
      End If
    Loop
  Else
    ReDim Preserve NewStrings(1 To 2)
    NewStrings(2) = FormatString(TmpStr, StrWidth, AlignStyle)
    StrCnt = 2
  End If
  'удаляем лишние пробелы
  For m = 1 To 2 * RowCnt - 1
    For n = 1 To 2 * ColCnt - 1
      ReportText(k + m - 1, l + n - 1) = ""
    Next n
    ReportText(k + m - 1, l) = Space(StrWidth)
  Next m
  
  Dim ss As String
  For m = 1 To 2 * (ColCnt - 1)
    n = Len(ReportText(k - 1, l + m))
    If m Mod 2 = 0 Then
      ss = IIf(Left(ReportText(k - 1, l), 1) = "", " ", Left(ReportText(k - 1, l), 1))
      ReportText(k - 1, l + m) = String(n, ss)
    Else
      Select Case Asc(Left(ReportText(k - 1, l + m), 1))
 '       Case 179
 '         ReportText(k - 1, l + m) = " "
        Case 180
          ReportText(k - 1, l + m) = Chr(217)
        Case 191
          ReportText(k - 1, l + m) = Chr(196)
        Case 194
          ReportText(k - 1, l + m) = Chr(196)
        Case 195
          ReportText(k - 1, l + m) = Chr(192)
        Case 197
          ReportText(k - 1, l + m) = Chr(193)
        Case 218
          ReportText(k - 1, l + m) = Chr(196)
'        Case Else
'           ReportText(k - 1, l + m) = String(n, Left(ReportText(k - 1, l + m), 1))
      End Select
    End If
    
    n = Len(ReportText(k + 2 * RowCnt - 1, l + m))
    If m Mod 2 = 0 Then
      ss = IIf(Left(ReportText(k + 2 * RowCnt - 1, l), 1) = "", " ", Left(ReportText(k + 2 * RowCnt - 1, l), 1))
      ReportText(k + 2 * RowCnt - 1, l + m) = String(n, ss)
    Else
      Select Case Asc(Left(ReportText(k + 2 * RowCnt - 1, l + m), 1))
''        Case 179
''          ReportText(k + 2 * RowCnt - 1, l + m) = " "
        Case 180
         ReportText(k + 2 * RowCnt - 1, l + m) = Chr(191)
        Case 192
          ReportText(k + 2 * RowCnt - 1, l + m) = Chr(196)
        Case 193
          ReportText(k + 2 * RowCnt - 1, l + m) = Chr(196)
        Case 195
          ReportText(k + 2 * RowCnt - 1, l + m) = Chr(218)
        Case 197
          ReportText(k + 2 * RowCnt - 1, l + m) = Chr(194)
        Case 217
          ReportText(k + 2 * RowCnt - 1, l + m) = Chr(196)
'        Case Else
'          ReportText(k + 2 * RowCnt - 1, l + m) = String(n, Left(ReportText(k + 2 * RowCnt - 1, l), 1))
      End Select
    End If
  Next m
  
  StrCnt = StrCnt - 1 '1st line - empty
  If StrCnt > RealStrCnt Then 'insert empty lines
    n = StrCnt - RealStrCnt
    For m = 1 To n
      Call insertRow(i)
    Next m
  End If
  
  RealStrCnt = RowCnt * 2 - 1 + InsertCount(i)
  
  InsPos = CurrentInsPos(i)
  For m = 0 To InsertCount(i) - 1
    For n = 1 To 2 * ColCnt - 1
      AdditionStrings(l + n - 1, InsPos + m) = ""
    Next n
    AdditionStrings(l, InsPos + m) = Space(StrWidth)
  Next m
  
  'по вертикали
  Select Case ma.Cells(1, 1).VerticalAlignment
    Case xlVAlignTop
      StartRow = 1
    Case xlVAlignBottom
      StartRow = RealStrCnt - StrCnt + 1
    Case xlVAlignCenter
      StartRow = (RealStrCnt - StrCnt) \ 2 + 1
    Case xlVAlignJustify
      If StrCnt = RealStrCnt Then
        StartRow = 1
      Else
        StartRow = 0 'особый случай
        LineStep = RealStrCnt \ StrCnt
        DeltaLines = (LineStep + 1) * (StrCnt - 1) + 1 - RealStrCnt
        For m = 1 To DeltaLines
          Call insertRow(i)
        Next m
      End If
  End Select
  RealStrCnt = RowCnt * 2 - 1 + InsertCount(i)
  
  'данные
  InsPos = CurrentInsPos(i)
  Dim HiddenFirst As Boolean
  HiddenFirst = (HiddenCols(j) Or HiddenRows(i)) And (ColCnt > 1)
  Dim l1 As Integer, l2 As Integer
  
  If Not HiddenFirst Then
    l1 = l
    l2 = l + 2
  Else 'переносим данные в соседний столбец
    l1 = l + 2
    l2 = l
  End If
  Select Case StartRow
    Case 1
      ReportText(k, l1) = NewStrings(2)
      If HiddenFirst Then ReportText(k, l2) = ""
      If StrCnt >= (1 + InsertCount(i)) Then n = InsertCount(i) Else n = StrCnt - 1
      For m = 0 To n - 1
        AdditionStrings(l1, InsPos + m) = NewStrings(m + 3)
        If HiddenFirst Then AdditionStrings(l2, InsPos + m) = ""
      Next m
      n = StrCnt - 1 - InsertCount(i)
      InsPos = 2 + InsertCount(i)
      For m = 1 To n
        ReportText(k + m, l1) = NewStrings(InsPos + m)
        If HiddenFirst Then ReportText(k + m, l2) = ""
      Next m
    Case 0
      ReportText(k, l1) = NewStrings(2)
      If HiddenFirst Then ReportText(k, l2) = ""
      ReDim BufStr(1 To RealStrCnt) As String
      For m = 1 To RealStrCnt
        BufStr(m) = Space(StrWidth)
      Next m
      m = 1
      n = 2
      While m <= RealStrCnt
        BufStr(m) = NewStrings(n)
        m = m + LineStep + 1
        n = n + 1
      Wend
      n = 2
      For m = 0 To InsertCount(i) - 1
        AdditionStrings(l1, InsPos + m) = BufStr(n)
        If HiddenFirst Then AdditionStrings(l2, InsPos + m) = ""
        n = n + 1
      Next m
      n = 1
      m = InsertCount(i) + 1
      While m <= RealStrCnt
        ReportText(k + n, l1) = BufStr(m)
        If HiddenFirst Then ReportText(k + n, l2) = ""
        m = m + 1
        n = n + 1
      Wend
    Case Else
      If StartRow > InsertCount(i) + 1 Then
        For m = 1 To StrCnt
          ReportText(k + m, l1) = NewStrings(m + 1)
          If HiddenFirst Then ReportText(k + m, l2) = ""
        Next m
      Else
        Linesleft = (RowCnt - 1) * 2 'строки в осн. табл
        n = StartRow - 2 ' смещение в доп. строках
        m = 2
        While (n < InsertCount(i)) And m <= (UBound(NewStrings))
          AdditionStrings(l1, InsPos + n) = NewStrings(m)
          If HiddenFirst Then AdditionStrings(l2, InsPos + n) = ""
          n = n + 1
          m = m + 1
        Wend
        n = m - 1
        For m = 1 To Min((RowCnt - 1) * 2, UBound(NewStrings) - n)
          ReportText(k + m, l1) = NewStrings(n + m)
          If HiddenFirst Then ReportText(k + m, l2) = ""
        Next m
      End If
  End Select
End Sub

Sub splitline(ByRef StrSrc As String, ByRef StrDest As String, ByVal MaxLen As Integer)
  Dim SpacePos As Integer, i As Integer
  Dim HasLF As Boolean
  
  HasLF = False
  If StrSrc = "" Then
    StrDest = ""
  Else
    SpacePos = 0
    If MaxLen > Len(StrSrc) Then MaxLen = Len(StrSrc)
    For i = 1 To MaxLen
      Select Case Asc(Mid(StrSrc, i, 1))
        Case 34, 36, 37, 39, 40, 41, 48 To 57, 65 To 90, 97 To 122, 128 To 175, 224 To 241
        ' ", $, %, ', (,), 0..9, A..Z, a..z
        Case 10
          SpacePos = i
          StrSrc = Left(StrSrc, i - 1) + " " + Right(StrSrc, Len(StrSrc) - i)
          HasLF = True
          Exit For
        Case Else
          SpacePos = i
      End Select
    Next i
    If (SpacePos = 0) Or (Not HasLF And MaxLen = Len(StrSrc)) Then SpacePos = MaxLen
    If (SpacePos = 1) And (MaxLen > 1) Then SpacePos = MaxLen
    StrDest = Left(StrSrc, SpacePos)
    StrSrc = Right(StrSrc, Len(StrSrc) - SpacePos)
    i = InStr(1, StrDest, Chr(10))
    While i > 0
        StrDest = Left(StrDest, i - 1) + " " + Right(StrDest, Len(StrDest) - i)
        i = InStr(1, StrDest, Chr(10))
    Wend
  End If
End Sub

Sub DelSpaces(ByVal StrNum As Integer)
  Dim TmpStr As String, TmpRow() As String
  Dim DeltaLen As Integer
  Dim j As Integer, RealLen As Integer
  
  RealLen = 1
  For j = 1 To Cols
    RealLen = RealLen + CellWidth(j) + 1
  Next j
  
  ReDim TmpRow(1 To 2 * Cols + 1)
  For j = 1 To 2 * Cols + 1
    TmpRow(j) = ReportText(StrNum, j)
  Next j
    
  TmpStr = JOIN97(TmpRow, "")
  DeltaLen = Len(TmpStr) - RealLen
  If DeltaLen > 0 Then
    j = 2
    Do While j < 2 * (Cols + 1)
      If DeltaLen = 0 Then Exit Do
      If Trim(ReportText(StrNum, j)) = "" And ReportText(StrNum, j) <> "" Then
        If Len(ReportText(StrNum, j)) < DeltaLen Then
          DeltaLen = DeltaLen - Len(ReportText(StrNum, j))
          ReportText(StrNum, j) = ""
          j = j + 2
        Else
          ReportText(StrNum, j) = Space(Len(ReportText(StrNum, j)) - DeltaLen)
          DeltaLen = 0
          Exit Do
        End If
      Else
        j = j + 2
      End If
    Loop
    If DeltaLen > 0 Then
      j = 2
      Dim TmpLen As Integer
      
      Do While j < 2 * (Cols + 1)
        TmpLen = Len(ReportText(StrNum, j)) - Len(RTrim(ReportText(StrNum, j)))
        If TmpLen > 0 Then
          If TmpLen >= DeltaLen Then
            ReportText(StrNum, j) = Left(ReportText(StrNum, j), Len(ReportText(StrNum, j)) - DeltaLen)
            DeltaLen = 0
            Exit Do
          Else
            ReportText(StrNum, j) = RTrim(ReportText(StrNum, j))
            DeltaLen = DeltaLen - TmpLen
          End If
        End If
        j = j + 2
      Loop
    End If
  End If
End Sub


Function JOIN97(JoinArr() As String, Delimiter As String) As String
  Dim TmpStr As String, i As Integer
  TmpStr = ""
  For i = LBound(JoinArr) To UBound(JoinArr) - 1
    TmpStr = TmpStr + JoinArr(i) + Delimiter
  Next i
  TmpStr = TmpStr + JoinArr(UBound(JoinArr))
  JOIN97 = TmpStr
End Function

Function Min(a As Integer, b As Integer) As Integer
  If a < b Then Min = a Else Min = b
End Function


Sub GetRealBorder(ByRef ReportRange As Range)
  Dim r As Range, ma As Range

  Dim Rows As Integer, Cols As Integer, i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer
  Dim RealCols As Integer, RealWidth As Integer
  Dim RealRows As Integer, RealHeight As Integer
  Dim RowCnt As Integer, ColCnt As Integer

  Set r = ReportRange
  Rows = r.Rows.Count
  Cols = r.Columns.Count
  ReDim DoneCells(1 To Rows, 1 To Cols)
  RealCols = Cols
  RealRows = Rows
  For i = 1 To Rows
    For j = 1 To Cols
      DoneCells(i, j) = False
    Next j
  Next i
  For i = 1 To Rows
    For j = 1 To Cols
      If DoneCells(i, j) Then Exit For
      Set ma = r.Cells(i, j).MergeArea
      RowCnt = ma.Rows.Count
      ColCnt = ma.Columns.Count
      RealWidth = (j - 1) + ColCnt
      RealHeight = (i - 1) + RowCnt
      If RealWidth > RealCols Then RealCols = RealWidth
      If RealHeight > RealRows Then RealRows = RealHeight
      If RealWidth > Cols Then k = Cols - j Else k = ColCnt - 1
      If RealHeight > Rows Then l = Rows - i Else l = RowCnt - 1
      For m = 0 To l
        For n = 0 To k
          DoneCells(i + m, j + n) = True
        Next n
      Next m
    Next j
  Next i
  Set ReportRange = r.Parent.Range(r.Parent.Cells(1, 1), r.Parent.Cells(RealRows, RealCols))
End Sub
