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 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
Public InsertCount() As Integer
Public InsRowCount As String
Public FirstStep As Boolean

Sub Demo()
  Call Export
End Sub

Function ExcelDos(filePath As String) As Integer
Dim ws As Object, fName As String
  Set ws = Application.ActiveWorkbook.ActiveSheet
  Set ReportRange = ws.Range(ws.[a1], LastCell(ws.[a1]))
  FirstStep = True
  Call ReadData
  Call FormatReport
  FirstStep = False
  Call ClearData
  Call ReadData
  Call FormatReport
  fName=filePath+ws.Name
  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]))
  FirstStep = True
  Call ReadData
  Call FormatReport
  FirstStep = False
  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 FirstStep 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
    PageWidth = PageWidth - Cols * 2
  
    ReDim CellWidth(1 To Cols) As Integer
  
    For i = 1 To Cols
      CellWidth(i) = PageWidth * ReportRange.Columns(i).Width / ReportWidth
      If CellWidth(i) <= 0 Then CellWidth(i) = 1
    Next i
  
    ReDim DataString(1 To Cols * 2 + 1) As String
    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)
  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
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 Len(ReportText(k, l)) > StrWidth 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) = " "
            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 FirstStep Then
                 CellWidth(j) = CellWidth(j) + DeltaLen
               End If
            End If
          End If 'подгон длины
          ReportText(k, 2 * j) = FormatString(ReportText(k, 2 * j), StrWidth, AlignStyle)
          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(xlLastCell)
    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
End Function

Sub GetCellBorders(r As Range)
  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) = " "
  If BLine And Not (LLine Or RLine) Then CellBorders(1) = Chr(179)
  If RLine And Not (BLine Or TLine) Then CellBorders(1) = Chr(196)
  If Not LLine And RLine And Not TLine And BLine Then CellBorders(1) = Chr(218)
  If Not LLine And RLine And TLine And Not BLine Then CellBorders(1) = Chr(192)
  If Not LLine And RLine And TLine And BLine Then CellBorders(1) = Chr(195)
  If LLine And Not RLine And Not TLine And BLine Then CellBorders(1) = Chr(191)
  If LLine And Not RLine And TLine And Not BLine Then CellBorders(1) = Chr(217)
  If LLine And Not RLine And TLine And BLine Then CellBorders(1) = Chr(180)
  If LLine And RLine And Not TLine And BLine Then CellBorders(1) = Chr(194)
  If LLine And RLine And TLine And Not BLine Then CellBorders(1) = Chr(193)
  If LLine And RLine And TLine And BLine Then CellBorders(1) = Chr(197)

'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) = " "
  If BLine And Not (LLine Or RLine) Then CellBorders(3) = Chr(179)
  If LLine And Not (BLine Or TLine) Then CellBorders(3) = Chr(196)
  If Not LLine And RLine And Not TLine And BLine Then CellBorders(3) = Chr(218)
  If Not LLine And RLine And TLine And Not BLine Then CellBorders(3) = Chr(192)
  If Not LLine And RLine And TLine And BLine Then CellBorders(3) = Chr(195)
  If LLine And Not RLine And Not TLine And BLine Then CellBorders(3) = Chr(191)
  If LLine And Not RLine And TLine And Not BLine Then CellBorders(3) = Chr(217)
  If LLine And Not RLine And TLine And BLine Then CellBorders(3) = Chr(180)
  If LLine And RLine And Not TLine And BLine Then CellBorders(3) = Chr(194)
  If LLine And RLine And TLine And Not BLine Then CellBorders(3) = Chr(193)
  If LLine And RLine And TLine And BLine Then CellBorders(3) = Chr(197)

'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) = " "
  If BLine And Not (LLine Or RLine) Then CellBorders(6) = Chr(179)
  If RLine And Not (BLine Or TLine) Then CellBorders(6) = Chr(196)
  If Not LLine And RLine And Not TLine And BLine Then CellBorders(6) = Chr(218)
  If Not LLine And RLine And TLine And Not BLine Then CellBorders(6) = Chr(192)
  If Not LLine And RLine And TLine And BLine Then CellBorders(6) = Chr(195)
  If LLine And Not RLine And Not TLine And BLine Then CellBorders(6) = Chr(191)
  If LLine And Not RLine And TLine And Not BLine Then CellBorders(6) = Chr(217)
  If LLine And Not RLine And TLine And BLine Then CellBorders(6) = Chr(180)
  If LLine And RLine And Not TLine And BLine Then CellBorders(6) = Chr(194)
  If LLine And RLine And TLine And Not BLine Then CellBorders(6) = Chr(193)
  If LLine And RLine And TLine And BLine Then CellBorders(6) = Chr(197)
  
'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) = " "
  If BLine And Not (LLine Or RLine) Then CellBorders(8) = Chr(179)
  If LLine And Not (BLine Or TLine) Then CellBorders(8) = Chr(196)
  If Not LLine And RLine And Not TLine And BLine Then CellBorders(8) = Chr(218)
  If Not LLine And RLine And TLine And Not BLine Then CellBorders(8) = Chr(192)
  If Not LLine And RLine And TLine And BLine Then CellBorders(8) = Chr(195)
  If LLine And Not RLine And Not TLine And BLine Then CellBorders(8) = Chr(191)
  If LLine And Not RLine And TLine And Not BLine Then CellBorders(8) = Chr(217)
  If LLine And Not RLine And TLine And BLine Then CellBorders(8) = Chr(180)
  If LLine And RLine And Not TLine And BLine Then CellBorders(8) = Chr(194)
  If LLine And RLine And TLine And Not BLine Then CellBorders(8) = Chr(193)
  If LLine And RLine And TLine And BLine Then CellBorders(8) = Chr(197)
End Sub

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


End Function

Function isEmptyCell(r As Range) As Boolean
  If Not IsEmpty(r.Value) Then
    isEmptyCell = False
  Else
    isEmptyCell = (r.Borders(xlEdgeTop).LineStyle = xlNone) ' And _
      (r.Borders(xlEdgeTop).LineStyle = xlNone) And _
      (r.Borders(xlEdgeLeft).LineStyle = xlNone) And _
      (r.Borders(xlEdgeRight).LineStyle = xlNone)
  End If
End Function

Function FormatString(s As String, StrLen As Integer, FormatStyle As Integer) As String
  Dim DeltaLen As Integer
  
  If (Len(s) < StrLen) Then
    DeltaLen = StrLen - Len(s)
    Select Case FormatStyle
      Case xlLeft
        FormatString = s + Space(DeltaLen)
      Case xlRight
        FormatString = Space(DeltaLen) + s
      Case xlCenter
        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 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
      DataString(j) = ReportText(i, j)
    Next j
    TmpStr = JOIN97(DataString, "")
    Print #FileNumber, TmpStr
    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 2 * Cols + 1
            DataString(j) = AdditionStrings(TmpPos, j)
          Next j
          TmpPos = TmpPos + 1
          TmpStr = JOIN97(DataString, "")
          Print #FileNumber, TmpStr
        Next k
      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
  

  For i = 1 To 2 * Rows + 1
    For j = 1 To 2 * Cols + 1
      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 2 * Cols + 1
            AdditionStrings(TmpPos, j) = ""
          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 TmpBuf() As String
  Dim i As Integer, j As Integer
  InsertCount(num) = InsertCount(num) + 1
  If InsRowCount = 0 Then
    ReDim AdditionStrings(1, 0 To Cols * 2 + 1)
  Else
    ReDim TmpBuf(1 To InsRowCount, 0 To Cols * 2 + 1)
    For i = 1 To InsRowCount
      For j = 0 To Cols * 2 + 1
        TmpBuf(i, j) = AdditionStrings(i, j)
      Next j
    Next i
    ReDim AdditionStrings(1 To InsRowCount + 1, 0 To Cols * 2 + 1)
    For i = 1 To InsRowCount
      For j = 0 To Cols * 2 + 1
        AdditionStrings(i, j) = TmpBuf(i, j)
      Next j
    Next i
  End If
  j = 2
  InsRowCount = InsRowCount + 1
  While j < Cols * 2 + 1
    If ReportText(2 * num, j - 1) <> "" Then
      AdditionStrings(InsRowCount, j - 1) = ReportText(2 * num, j - 1)
    Else
      AdditionStrings(InsRowCount, j - 1) = " "
    End If
    AdditionStrings(InsRowCount, j) = Space(CellWidth(j / 2))
    If ReportText(2 * num, j + 1) = "" Then
      AdditionStrings(InsRowCount, j + 1) = " "
    Else
      AdditionStrings(InsRowCount, j + 1) = ReportText(2 * num, j + 1)
    End If
    j = j + 2
  Wend
  AdditionStrings(InsRowCount, 0) = 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
  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) = " "))
'      If Not DoneCells(i, l / 2) Then
        StrWidth = StrWidth + CellWidth(l / 2) + 1
        ReportText(k, l) = ""
        ReportText(k, l + 1) = ""
        DoneCells(i, l / 2) = True
'      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 FirstStep Then
    CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
  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
  
  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
           StrWidth = StrWidth + CellWidth(ll / 2) + 1
           ReportText(k, ll) = ""
           ReportText(k, ll + 1) = ""
           DoneCells(i, ll / 2) = True
'         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
          StrWidth = StrWidth + CellWidth(mm / 2) + 1
          ReportText(k, mm) = ""
          ReportText(k, mm - 1) = ""
          DoneCells(i, mm / 2) = True
        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 FirstStep Then
    CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
  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
  StartL = l
  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 DoneCells(i, l / 2))
        StrWidth = StrWidth + CellWidth(l / 2) + 1
        ReportText(k, l) = ""
        ReportText(k, l - 1) = ""
        DoneCells(i, l / 2) = True
        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 FirstStep Then
    CellWidth(StartL / 2) = CellWidth(StartL / 2) + DeltaLen
  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
    
  DeltaLen = Len(ReportText(k, l)) - StrWidth
  TmpCnt = DeltaLen \ StrWidth
  If DeltaLen Mod StrWidth <> 0 Then TmpCnt = TmpCnt + 1
  'вставляем строки
  If TmpCnt > InsertCount(i) Then
    ttc = TmpCnt - InsertCount(i)
    For tt = 1 To ttc
      Call insertRow(i)
    Next tt
  End If
  TmpPos = CurrentInsPos(i)
  TmpStr = ReportText(k, l)
  ReportText(k, l) = Left(TmpStr, StrWidth)
  TmpStr = Right(TmpStr, DeltaLen)
  For jj = 0 To TmpCnt - 1
    If Len(TmpStr) >= StrWidth Then
      AdditionStrings(TmpPos + jj, l) = Left(TmpStr, StrWidth)
      TmpStr = Right(TmpStr, Len(TmpStr) - StrWidth)
    Else
      AdditionStrings(TmpPos + jj, l) = FormatString(TmpStr, StrWidth, AlignStyle)
    End If
  Next jj
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
  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
  Next m
  For m = 1 To 2 * RowCnt - 1
      ReportText(k + m - 1, l) = Space(StrWidth)
  Next m
  
  For m = 1 To 2 * (ColCnt - 1)
    n = Len(ReportText(k - 1, l + m))
    If m Mod 2 = 0 Then
      ReportText(k - 1, l + m) = String(n, Left(ReportText(k - 1, l), 1))
    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
      ReportText(k + 2 * RowCnt - 1, l + m) = String(n, Left(ReportText(k + 2 * RowCnt - 1, l), 1))
    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(InsPos + m, l + n - 1) = ""
    Next n
  Next m
  For m = 0 To InsertCount(i) - 1
    AdditionStrings(InsPos + m, l) = 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)
  Select Case StartRow
    Case 1
      ReportText(k, l) = NewStrings(2)
      If StrCnt >= (1 + InsertCount(i)) Then n = InsertCount(i) Else n = StrCnt - 1
      For m = 0 To n - 1
        AdditionStrings(InsPos + m, l) = NewStrings(m + 3)
      Next m
      n = StrCnt - 1 - InsertCount(i)
      InsPos = 2 + InsertCount(i)
      For m = 1 To n
        ReportText(k + m, l) = NewStrings(InsPos + m)
      Next m
    Case 0
      ReportText(k, l) = NewStrings(2)
      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(InsPos + m, l) = BufStr(n)
        n = n + 1
      Next m
      n = 1
      m = InsertCount(i) + 1
      While m <= RealStrCnt
        ReportText(k + n, l) = BufStr(m)
        m = m + 1
        n = n + 1
      Wend
    Case Else
      If StartRow > InsertCount(i) + 1 Then
        For m = 1 To StrCnt
          ReportText(k + m, l) = NewStrings(m + 1)
        Next m
      Else
        Linesleft = (RowCnt - 1) * 2 'строки в осн. табл
        n = StartRow - 2 ' смещение в доп. строках
        m = 2
        While (n < InsertCount(i)) And m <= (UBound(NewStrings))
          AdditionStrings(InsPos + n, l) = NewStrings(m)
          n = n + 1
          m = m + 1
        Wend
'        n = StrCnt - (RowCnt - 1) * 2 + 2
        n = m - 1
        For m = 1 To Min((RowCnt - 1) * 2, UBound(NewStrings) - n)
          ReportText(k + m, l) = NewStrings(n + m)
        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
   
  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 Else
          SpacePos = i
      End Select
    Next i
    If SpacePos = 0 Then SpacePos = MaxLen
    If (SpacePos = 1) And (MaxLen > 1) Then SpacePos = MaxLen
    StrDest = Left(StrSrc, SpacePos)
    StrSrc = Right(StrSrc, Len(StrSrc) - SpacePos)
  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

