'===========================================================================
' Subject: DBF MANAGER                       Date: 07-07-98 (14:23)       
' Author:  Alexander Podkolzin               Code: PB                     
' Origin:  app@nw.sbank.e-burg.su          Packet: PB.ABC
'===========================================================================
'---------------------------------------------------------------------------
' DBF manager. PB3+
' This program is just a hint how to build a real product.
' Status: public domain.
'
' Special thanks to Ethan Winer for his excellent code and explanations.
' Thanks to all ABC contributors, whose ideas i used in the program.
'
' If you'll have a question, drop me a line.
' Author: Alexander Podkolzin.
'---------------------------------------------------------------------------
 $DIM ALL
 $CPU 80386      '!!! N.B. !!!         'Check your CPU
 $LIB ALL OFF
 $COM 0
 $STRING 8
 $SOUND 1
 $ERROR ALL OFF
 $OPTION CNTLBREAK OFF
 $DEBUG MAP OFF
 $FLOAT NPX      '!!! N.B. !!!         'Check if you have it
 $DYNAMIC
 $OPTIMIZE SIZE
 $COMPILE EXE
'---------------------------------------------------------------------------
 %FALSE = 0
 %TRUE = -1
 %ESC_key   = &H001B
 %ENTER_key = &H000D
 %TAB_key   = &H0009
 %BCSP_key  = &H0008
 %INS_key   = &H5200
 %HOME_key  = &H4700
 %PGUP_key  = &H4900
 %PGDN_key  = &H5100
 %DEL_key   = &H5300
 %END_key   = &H4F00
 %UP_key    = &H4800
 %LEFT_key  = &H4B00
 %DOWN_key  = &H5000
 %RIGHT_key = &H4D00
 %CTRL_PG_UP_key = &H8400
 %CTRL_PG_DOWN_key = &H7600
'---------------------------------------------------------------------------
' Ethan Winer`s DBF procedures, converted to PB with some changes.
' First of all you have to remember, that OPTION BINARY BASE here
' equals to ZERO!
' You can compile this chunk of code as a UNIT.
'////////////////////////////////////\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
 Type DBFHeadStruc

   Version As Integer
   Memo As Integer
   Year As Integer
   Month As Integer
   Day As Integer
   FirstRec As Integer
   TotalRecs As Long
   RecLen As Integer
   TFields As Integer

 End Type
'---------------------------------------------------------------------------
 Type FieldStruc

   Bname As String * 10                'Field name
   FType As String * 1                 'Field type (C, D, L, M, N)
   FOff As Integer                     'Field offset
   FLen As Integer                     'Field length
   Dec As Integer                      '# Decimals

 End Type
'---------------------------------------------------------------------------
'Procedures declarations list:
'
 Declare Function Deleted( _
             Record As String _
             ) As Integer
 Declare Function GetField( _
             Record As String, _
             FldNum As Integer, _
             FldArray() As FieldStruc _
             ) As String
 Declare Function GetFldNum( _
             FieldName As String, _
             FldArray() As FieldStruc _
             ) As Integer
 Declare Function PackDate()  As String
 Declare Function Padded( _
             Fld As String, _
             FLen As Integer _
             ) As String
 Declare Sub CloseDBF( _
             FileNum As Integer, _
             TotalRecs As Long _
             )
 Declare Sub CreateDBF( _
             FileName As String, _
             FieldArray() As FieldStruc _
             )
 Declare Sub GetRecord( _
             FileNum As Integer, _
             RecNum As Long, _
             Record As String, _
             Header As DBFHeadStruc _
             )
 Declare Sub OpenDBF( _
             FileNum As Integer, _
             FileName As String, _
             Header As DBFHeadStruc, _
             FldArray() As FieldStruc _
             )
 Declare Sub SetField( _
             Record As String, _
             FText As String, _
             FldNum As Integer, _
             FldArray() As FieldStruc _
             )
 Declare Sub SetRecord( _
             FileNum As Integer, _
             RecNum As Long, _
             Record As String, _
             Header As DBFHeadStruc _
             )
'---------------------------------------------------------------------------
 Sub CloseDBF(FileNum As Integer, _
              TotalRecs As Long _
             ) Static Public

   Dim Temp As String
   Dim RecLen As Integer
   Dim FirstRec As Integer
   Dim EndPos As Long

   Get #FileNum, 11, FirstRec
   Get #FileNum, 16, RecLen
   Temp = PackDate()
   Put #FileNum, 1, Temp
   Put #FileNum, 4, TotalRecs
   EndPos = (TotalRecs * RecLen) + FirstRec
   Seek #FileNum, EndPos
   Put$ #FileNum, Chr$(26)             'Important !!!
   Close #FileNum

 End Sub
'---------------------------------------------------------------------------
 Sub CreateDBF(FileName As String, _
               FieldArray() As FieldStruc _
              ) Public

   Dim TFields As Integer
   Dim HLen As Integer
   Dim Header As String
   Dim Memo As Integer
   Dim FldBuf As String
   Dim ZeroStuff As String
   Dim FldOff As Integer
   Dim RecLen As Integer
   Dim i As Integer
   Dim Version As Integer

   TFields = Ubound(FieldArray)
   HLen = TFields * 32 + 34
   Header = String$(HLen, 0)
   Memo = 0

   FldBuf = String$(32, 0)
   ZeroStuff = FldBuf
   FldOff = 33
   RecLen = 1

   For i = 1 To TFields

     Mid$(FldBuf, 1) = FieldArray(i).Bname
     Mid$(FldBuf, 12) = FieldArray(i).FType
     Mid$(FldBuf, 17) = Chr$(FieldArray(i).FLen)
     Mid$(FldBuf, 18) = Chr$(FieldArray(i).Dec)
     Mid$(Header, FldOff) = FldBuf
     Lset FldBuf = ZeroStuff
     FldOff = FldOff + 32
     If FieldArray(i).FType = "M" Then Memo = -1
     RecLen = RecLen + FieldArray(i).FLen

   Next

   If Memo Then Version = 131 Else Version = 3
   Mid$(Header, 1) = Chr$(Version)
   Mid$(Header, 2) = PackDate()
   Mid$(Header, 5) = Mkl$(0)          'Total records
   Mid$(Header, 9) = Mki$(HLen)       'Size of header
   Mid$(Header, 11, 2) = Mki$(RecLen) 'Record length
   Mid$(Header, FldOff) = Chr$(13)
   Mid$(Header, FldOff + 2) = Chr$(26)

   i = Freefile
   Open FileName For Binary As #i
   Put #i, 0, Header
   Close #i

 End Sub
'---------------------------------------------------------------------------
 Function Deleted(Record As String) Static Public As Integer

   Function = (Left$(Record, 1) = "*")

 End Function
'---------------------------------------------------------------------------
 Function GetField(Record As String, _
                   FldNum As Integer, _
                   FldArray() As FieldStruc _
                  ) Static Public As String

   Function = Mid$(Record, FldArray(FldNum).FOff, FldArray(FldNum).FLen)

 End Function
'---------------------------------------------------------------------------
 Function GetFldNum(FieldName As String, _
                    FldArray() As FieldStruc _
                   ) Static Public As Integer

   Dim i As Integer
   For i = 1 To Ubound(FldArray)
     If FldArray(i).Bname = FieldName Then
       Function = i
       Exit Function
     End If
   Next

 End Function
'---------------------------------------------------------------------------
 Sub GetRecord(FileNum As Integer, _
               RecNum As Long, _
               Record As String, _
               Header As DBFHeadStruc _
              ) Static Public

   Dim RecOff As Long
   RecOff = ((RecNum - 1) * Header.RecLen) + Header.FirstRec
   Get FileNum, RecOff - 1, Record

 End Sub
'---------------------------------------------------------------------------
 Sub OpenDBF(FileNum As Integer, _
             FileName As String, _
             Header As DBFHeadStruc, _
             FldArray() As FieldStruc _
            ) Static Public

   Dim HLen As Integer
   Dim Buffer As String
   Dim OffSet As Integer
   Dim BuffOff As Integer
   Dim Zero As String
   Dim i As Integer
   Dim Fterm As Integer

   Open FileName For Binary As FileNum
   Get FileNum, 8, HLen
   Header.FirstRec = HLen + 1
   Buffer = Space$(HLen)

   Get FileNum, 0, Buffer
   Header.Version = Asc(Buffer)
   If Header.Version = 131 Then
     Header.Version = 3
     Header.Memo = -1
   Else
     Header.Memo = 0
   End If

   Header.Year = Asc(Mid$(Buffer, 2, 1))
   Header.Month = Asc(Mid$(Buffer, 3, 1))
   Header.Day = Asc(Mid$(Buffer, 4, 1))
   Header.TotalRecs = Cvl(Mid$(Buffer, 5, 4))
   Header.RecLen = Cvi(Mid$(Buffer, 11, 2))
   Header.TFields = (HLen - 33) \ 32

   Redim FldArray(1 To Header.TFields) As FieldStruc
   OffSet = 2
   BuffOff = 33
   Zero = Chr$(0)

   For i = 1 To Header.TFields

     FTerm = Instr(BuffOff, Buffer, Zero)
     FldArray(i).Bname = Mid$(Buffer, BuffOff, FTerm - BuffOff)
     FldArray(i).FType = Mid$(Buffer, BuffOff + 11, 1)
     FldArray(i).FOff = OffSet
     FldArray(i).FLen = Asc(Mid$(Buffer, BuffOff + 16, 1))
     FldArray(i).Dec = Asc(Mid$(Buffer, BuffOff + 17, 1))
     OffSet = OffSet + FldArray(i).FLen
     BuffOff = BuffOff + 32

   Next

 End Sub
'---------------------------------------------------------------------------
 Function PackDate() Static Public As String

   Function = Chr$(Val(Right$(Date$, 2))) _
            + Chr$(Val(Left$(Date$, 2))) _
            + Chr$(Val(Mid$(Date$, 4, 2)))

 End Function
'---------------------------------------------------------------------------
 Sub SetField(Record As String, _
              FText As String, _
              FldNum As Integer, _
              FldArray() As FieldStruc _
             ) Static Public

   FText = Padded(FText, FldArray(FldNum).FLen)
   Mid$(Record, FldArray(FldNum).FOff, FldArray(FldNum).FLen) = FText

 End Sub
'---------------------------------------------------------------------------
 Sub SetRecord(FileNum As Integer, _
               RecNum As Long, _
               Record As String, _
               Header As DBFHeadStruc _
              ) Static Public

   Dim RecOff As Long
   RecOff = ((RecNum - 1) * Header.RecLen) + Header.FirstRec
   Put FileNum, RecOff - 1, Record

 End Sub
'---------------------------------------------------------------------------
 Function Padded(Fld As String, _
                 FLen As Integer _
                ) Static Public As String

   Dim Temp As String
   Dim s As String

   Temp = Space$(FLen)
   s = Flexchr$                   'Save PB system variable
   Flexchr$ = Chr$(0)             'Change it
   Lset Temp = Fld
   Flexchr$ = s                   'Restore it
   Function = Temp

 End Function
'---------------------------------------------------------------------------
' End of Ethan Winer`s DBF procedures.
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\///////////////////////////////////////

 Declare Function GetStrLoc(BYVAL AllocHandle As Integer) As Long
 Declare Function fEditLine( _
         Byval Edit As String, _  'String to edit,
         Byval x As Integer, _    'Colomn,
         Byval y As Integer, _    'Row,
         Byval n As Integer, _    'Length of edit window,
         Byval Mlen As Integer, _ 'Max length of edit string,
         Abort As Integer _       'ESC was pressed.
         ) As String
 Declare Function fGetKey() As Integer
 Declare Function fGetMenu( _
         T() As String, _
         Byval Hed As String, _
         Byval xb As Integer, _
         Byval yb As Integer, _
         Byval wa As Integer, _
         Byval ba As Integer, _
         Byval Init As Integer _
         ) As Integer
 Declare Function fGetScrnSeg()  As Integer
 Declare Function fSelectDBFRec( _
         Byval Hed As String, _
         Byval FileNum As Integer, _
         Header As DBFHeadStruc _
         ) As Long
 Declare Sub Qprint( _
         BYVAL Hor As Integer, _
         BYVAL ver As Integer, _
         A As String _
         )
 Declare Sub Rprint( _
         Byval x As Integer, _
         Byval y As Integer, _
         Byval s As String, _
         Byval c As Integer _
         )
 Declare Sub MakeWindow( _
         Byval t As Integer, _
         Byval xb As Integer, _
         Byval yb As Integer, _
         Byval xe As Integer, _
         Byval ye As Integer, _
         Byval wa As Integer, _
         Byval sh As Integer _
         )
 Declare Sub QFill( _
         Byval xb As Integer, _
         Byval yb As Integer, _
         Byval xe As Integer, _
         Byval ye As Integer, _
         Byval Attr As Integer, _
         Byval FillChar As Integer _
         )
 Declare Sub RemoveWindow()
 Declare Sub RestoreWindow( _
         Byval W As String, _
         Byval Xb As Integer, _
         Byval Yb As Integer _
         )
 Declare Sub SaveWindow( _
         W As String, _
         Byval Xb As Integer, _
         Byval Yb As Integer, _
         Byval Xe As Integer, _
         Byval Ye As Integer, _
         Byval sh As Integer _
         )
 Declare Sub ShowText(Byval Hed as String, _
         Txt() As String, _
         Byval Twin As Integer, _
         Byval xb As Integer, _
         Byval yb As Integer, _
         Byval xe As Integer, _
         Byval ye As Integer, _
         Byval Wa As Integer, _
         Byval Shadow As Integer _
         )
 Declare Sub Windo( _
         Byval t As Integer, _
         Byval xb As Integer, _
         Byval yb As Integer, _
         Byval xe As Integer, _
         Byval ye As Integer, _
         Byval wa As Integer, _
         Byval sh As Integer _
         )
'---------------------------------------------------------------------------
 %MaxWin = 20
 %MaxFields = 100
 Dim Wins(1 To %MaxWin) As Shared String
 Dim WinPtr As Shared Integer

 Dim s As String
 Dim sa As String
 Dim Abort As Integer
 Dim i As Integer
 Dim k As Integer
 Dim l As Long
 Dim m As Integer
 Dim xb As Integer
 Dim yb As Integer
 Dim xe As Integer
 Dim ye As Integer
 Dim T(10) As Shared String
 Dim MainItem As Shared Integer
 Dim NeedEdit As Shared Integer

 Dim DBFName As String
 Dim DBFrecord As String
 Dim DBFrecChanged As Integer

 Dim Header AS DBFHeadStruc
 Dim Temp As String
 Dim FldType As Integer
 Dim FldStruc(1 To %MaxFields) As Shared FieldStruc
 Dim Record As Shared String

'    Header variables:

 Dim Version As Integer
 Dim Memo As Integer
 Dim Year As Integer
 Dim Month As Integer
 Dim Day As Integer
 Dim FirstRec As Integer
 Dim TotalRecs As Long
 Dim RecLen As Integer
 Dim TFields As Integer

 Dim FileDBF As Shared Integer

 Cls
 Print "Enter DBF file name (no extension)        .DBF"

 s = "ORG" 'File name for debugging, delete this line or change file name...
 s = "KLIRING"
 s = fEditLine(s, 35, 1, 8, 8, Abort)
 If Abort Then
   Print "Program aborted."
   End
 End If
 DBFname = Ucase$(Remove$(s, Any " .") + ".DBF")
 If Dir$(DBFname) = "" Then
   Print "File " + DBFname + " not found"
   Print "Program aborted."
   End
 End If

 FileDBF = Freefile
 OpenDBF FileDBF, DBFName, Header, FldStruc()
 CloseDBF FileDBF, Header.TotalRecs

 Cls
 T(01) = "Header info"
 T(02) = "Fields info"
 T(03) = "Brows DBF"
 T(04) = "Edit DBF"
 T(05) = "Exit"

 WinPtr = 0
 Qfill 1, 1, 80, 25, &H02, 176
 Qfill 1, 1, 80, 1, &H1E, 32
 Qfill 1, 25, 80, 25, &H1E, 32
 Qprint 2, 1, "File name: " + DBFname
 MainItem = 1
 Do

   i = fGetMenu(T(), "", 2, 2, &H1E, &H70, MainItem)

   If i > 0 Then
     MainItem = i
     Select Case MainItem
     Case 1                         'Header info

       Version = Header.Version
       Memo = Header.Memo
       Year = Header.Year
       Month = Header.Month
       Day = Header.Day
       FirstRec = Header.FirstRec
       TotalRecs = Header.TotalRecs
       RecLen = Header.RecLen
       TFields = Header.Tfields
       MakeWindow 2, 20, 4, 60, 17, &H1B, 1
       Rprint 33, 05, "Header info:", 12
       Rprint 27, 07, "Version number       =" + Str$(Version), 11
       Rprint 27, 08, "Memo                 =" + Str$(Memo), 11
       Rprint 27, 09, "Year                 =" + Str$(Year), 11
       Rprint 27, 10, "Month                =" + Str$(Month), 11
       Rprint 27, 11, "Day                  =" + Str$(Day), 11
       Rprint 27, 12, "First record offset  =" + Str$(FirstRec), 11
       Rprint 27, 13, "Total records        =" + Str$(TotalRecs), 11
       Rprint 27, 14, "Record length        =" + Str$(RecLen), 11
       Rprint 27, 15, "Total fields         =" + Str$(TFields), 11
       i = fGetKey()
       RemoveWindow

     Case 2                         'Fields info

       Tfields = Header.Tfields
       Redim Txt(1 To TFields) As String

       For i = 1 To TFields
         Txt(i) = Space$(52)
         Mid$(Txt(i),  2) = Using$("###", i)
         Mid$(Txt(i),  8) = FldStruc(i).Bname
         Mid$(Txt(i), 21) = FldStruc(i).FType
         Mid$(Txt(i), 29) = Str$(FldStruc(i).FOff)
         Mid$(Txt(i), 39) = Str$(FldStruc(i).FLen)
         Mid$(Txt(i), 49) = Str$(FldStruc(i).Dec)
       Next

       s = "  #   Field name   Type     Offset    Length    Dec"
       ShowText s, Txt(), 2, 13, 3, 67, 22, &H1B, 1

     Case 3, 4                      'Brows DBF, Edit

       If Header.TotalRecs < 1 Then

         MakeWindow 1, 2, 4, 30, 6, &H4F, 1
         Qprint 4, 5, "Total records = 0, sorry!"
         i = fGetKey()
         RemoveWindow
         Exit Select

       End If

       If MainItem = 4 Then
         NeedEdit = %TRUE
       Else
         NeedEdit = %FALSE
       End If

       FileDBF = Freefile
       OpenDBF FileDBF, DBFName, Header, FldStruc()
       i = fSelectDBFrec(sa, FileDBF, Header)
       CloseDBF FileDBF, Header.TotalRecs

     Case 5                         'Exit
       Exit Loop
     End select
   Else
     Exit Loop
   End If
 Loop

 Cls

 End

'---------------------------------------------------------------------------
' This function is constructed specially for this programm.
' The function moves text, not cursor.
'
 Function fSelectDBFrec( _
          Byval Hed As String, _
          Byval FileNum As Integer, _
          Header As DBFHeadStruc _
          ) As Long

   Dim i As Integer
   Dim k As Integer
   Dim l As Long
   Dim Fld As Integer
   Dim m As Integer
   Dim s As String
   Dim sa As String
   Dim sb As String
   Dim Txt(0) As String
   Dim RecNum As Long
   Dim Lpage As Integer
   Dim BegPos As Integer
   Dim BegX As Integer
   Dim LRkey As Integer
   Dim Abort As Integer
   Dim Txz(0) As String
   Dim Moving As Static Integer

   If Moving = 0 Then Moving = 1
   m = 7
   sa = Chr$(25) + "#     "
   Mid$(sa, 7) = Chr$(25)
   For i = 1 To Header.Tfields    'Prepare string header:
     k = FldStruc(i).FLen + 2     '+2 - gap between fields
     If k < 12 Then k = 12
     Incr m, k
     s = Space$(k)
     Mid$(s, k) = Chr$(25)        'Points to field position - 1
     Mid$(s, 1) = FldStruc(i).Bname
     sa = sa + s
   Next
   sa = sa + Space$(76)

   Mid$(sa, Len(sa)) = " "
   Redim Tabs(Header.Tfields + 1, 2) As Integer
   Tabs(1, 1) = 1
   Tabs(1, 2) = 5
   k = 1
   For i = 2 To Header.Tfields + 1
     k = Instr(k + 1, sa, Chr$(25))
     Tabs(i, 1) = k
     Tabs(i, 2) = FldStruc(i - 1).FLen
   Next
   Replace Chr$(25) With " " In sa
   sa = Mid$(sa, 2) + " "

   MakeWindow 2, 1, 2, 80, 24, &H20, 0
   If NeedEdit Then
     Rprint 20, 24,"(Select record, field and press <Enter>)", 10
   End If

   If NeedEdit Then
     Redim Txz(3)
     Txz(01) = "Colomn moving"
     Txz(02) = "Row moving"
     Moving = fGetMenu(Txz(), "?", 2, 2, &H1E, &H70, Moving)
     If Moving = 0 Then Moving = 1
   End If

   Lpage = 20
   RecNum = 1
   BegPos = 1
   BegX = 1
   Do

     If BegPos < 1 Then BegPos = 1
     If BegPos > Header.Tfields + 1 Then BegPos = Header.Tfields + 1
     BegX = Tabs(BegPos, 1)

     If RecNum < 1 Then
       RecNum = 1
       Iterate Loop
     End If

     If RecNum > Header.TotalRecs Then
       RecNum = Header.TotalRecs
       Iterate Loop
     End If

     Gosub MakeDBFpage            'Show current page from RecNum record

     LRkey = %FALSE
     i = fGetKey
     Select Case i
     Case %ESC_key
       Function = 0
       Exit Loop
     Case %ENTER_key
       If NeedEdit Then
         If BegPos = 1 Then
           Incr BegPos
           Iterate Loop
         End If

         s = Mid$(Txt(1), Tabs(BegPos, 1), Tabs(BegPos, 2))

         s = fEditLine(s, 3, 4, _
                       Min(Tabs(BegPos, 2), 77), _
                       Tabs(BegPos, 2), _
                       Abort)

         If Abort Then Iterate Loop 'No writting changes for the record...

'------------------------- Writting changes: -------------------------------

         GetRecord FileNum, RecNum, Record, Header
         SetField Record, s, BegPos - 1, FldStruc()
         SetRecord FileNum, RecNum, Record, Header

'---------------------------------------------------------------------------

         If Moving = 1 Then
           Incr RecNum
         Else
           Incr BegPos
           If BegPos > Header.Tfields + 1 Then
             BegPos = 2
             Incr RecNum
           End If
         End If

       Else
         Function = RecNum
         Exit Loop
       End If
     Case %LEFT_key
       Decr BegPos
       LRkey = %TRUE
     Case %Right_key, %TAB_key
       Incr BegPos
       LRkey = %TRUE
     Case %Home_key
       BegPos = 1
       LRkey = %TRUE
     Case %End_key
       BegPos = Header.Tfields + 1
       LRkey = %TRUE
     Case %Up_key
       Decr RecNum
     Case %Down_key
       Incr RecNum
     Case %PgUp_key
       Decr RecNum, Lpage
     Case %PgDn_key
       Incr RecNum, Lpage
     Case %CTRL_PG_UP_key
       RecNum = 1
     Case %CTRL_PG_DOWN_key
       RecNum = Header.TotalRecs
     End Select

   Loop
   RemoveWindow
   Exit Function

   MakeDBFpage:
   If Not LRkey Then
     Redim Txt(Lpage) As String
   End If
   Record = Space$(7 + Header.RecLen)
   Qfill 2, 4, 79, 4, &H70, 0
   Rprint 3, 2, Using$("Field=###:", BegPos - 1) _
              + Using$("Len=###:",Tabs(BegPos, 2)) _
              + Using$("Record=#####", RecNum), 15
   For i = 1 To Lpage
     If Not LRkey Then
       l = RecNum + i - 1
       Txt(i) = Space$(Len(sa) + 76)
       If l <= Header.TotalRecs Then
         Mid$(Txt(i), 1) = Ltrim$(Str$(l))
         GetRecord FileNum, l, Record, Header
         For Fld = 2 TO Header.TFields + 1
           s = GetField(Record, Fld - 1, FldStruc())
           Mid$(Txt(i), Tabs(Fld, 1)) = s
         Next
       End If
     End If
     Rprint  3, 3, Mid$(sa, BegX, 76), 11
     Qprint 3, i + 3, Mid$(Txt(i), BegX, 76)
   Next
   Return

 End Function
'---------------------------------------------------------------------------
 Sub ShowText(Byval Hed as String, _    'One string header
     Txt() As String, _                 'Text array,
     Byval Twin As Integer, _           'Win type,
     Byval xb As Integer, _             'Win place to,
     Byval yb As Integer, _             '...
     Byval xe As Integer, _             '...
     Byval ye As Integer, _             '...
     Byval Wa As Integer, _             'Win attributes
     Byval Shadow As Integer _
     )

   Dim BegX As Integer
   Dim BegY As Integer
   Dim EndY As Integer
   Dim i As Integer
   Dim k As Integer
   Dim Lpage As Integer
   Dim MaxLength As Integer
   Dim Nlines As Integer
   Dim s As String
   Dim Wpage As Integer
   Dim Hrl As Integer

   Hrl = 16
   MaxLength = 0
   For i = 1 To Ubound(Txt$())
     If Txt$(i) = "" Then Exit For
     MaxLength = Max(Len(Txt$(i)), MaxLength)
   Next i
   Nlines = i - 1

   If Nlines < 1 Then Exit Sub
   MakeWindow Twin, xb, yb, xe, ye, wa, Shadow
   Wpage = xe - xb - 2         ' Width
   MaxLength = Max(MaxLength, Wpage)
   Lpage = ye - yb - 1         ' Length
   BegX = 1
   BegY = 1
   EndY = Min(Lpage, Nlines)
   s = "< Lines:" + Str$(Nlines) + " >"
   Qprint xe - Len(s), ye, s

   Do

     If BegY < 1 Then BegY = 1
     If BegY > Nlines Then BegY = Nlines

     If BegX < 1 Then BegX = 1
     i = MaxLength - (xe - xb - 1) + 2
     If BegX > i Then BegX = i

     s = Space$(MaxLength)        'Print header
     Mid$(s, 1) = Hed
     Rprint xb + 2, yb + 1, Mid$(s, BegX, Wpage), 12

     For i = BegY To BegY + Lpage - 2  'Print lines
       s = Space$(MaxLength)
       If i <= Nlines Then Mid$(s, 1) = Txt$(i)
       Qprint xb + 1, yb + i - BegY + 2, Mid$(s, BegX, Wpage)
     Next i
     Gosub MakeRulers

     k = fGetKey()
     Select Case k
     Case %Left_key
       Decr BegX
     Case %Right_key
       Incr BegX
     Case %Home_key
       BegX = 1
     Case %End_key
        BegX = MaxLength - (xe - xb - 1) + 1
        If BegX < 1 Then BegX = 1
     Case %Up_key
       Decr BegY
     Case %Down_key
       Incr BegY
     Case %PgUp_key
       Decr BegY, Lpage
     Case %PgDn_key
       Incr BegY, Lpage
     Case %Tab_key
       Incr BegX, 4
     Case %BcSp_key
       Decr BegX, 4
     Case %CTRL_PG_UP_key
       BegX = 1
       BegY = 1
     Case %CTRL_PG_DOWN_key
       BegX = 1
       BegY = Nlines
     Case %ESC_key, %ENTER_key
       Exit Loop
     End Select
   Loop
   RemoveWindow
   Exit Sub

   MakeRulers:

   If Lpage < Nlines Then         'Vertical ruler
     Qfill xe, yb + 2, xe, ye - 2, 0, 176
     k = ((BegY - 1) * Lpage) \ Nlines
     If k < 2 Then k = 2
     If EndY = Nlines Then k = Lpage - 1
     Qprint xe, yb + k, Chr$(10)
   End If

   If xe - xb < MaxLength Then    'Horizontal ruler
     Qfill xb + 1, ye, xb + Hrl, ye, 0, 176
     k = ((BegX - 1) * Hrl) \ Hrl
     If k < 1 Then k = 1
     If k > Hrl Then k = Hrl
     Qprint xb + k, ye, Chr$(10)
   End If

   Return

 End Sub
'---------------------------------------------------------------------------
'
' Returns edited string of Mlen length, if ESC was pressed Abort = TRUE.
' Max length restricted with $STRING size

 Function fEditLine( _
          Byval Edit As String, _  'String to edit,
          Byval x As Integer, _    'Colomn,
          Byval y As Integer, _    'Row,
          Byval n As Integer, _    'Length of edit window,
          Byval Mlen As Integer, _ 'Max length of edit string,
          Abort As Integer _       'ESC was pressed.
          ) As String

   Dim Ins As Static Integer       'Switcher of INS mode
   Dim OldX As Integer
   Dim OldY As Integer
   Dim Vis As Integer
   Dim Sl1 As Integer
   Dim Sl2 As Integer
   Dim OldColor As Integer
   Dim ScrColor As Integer
   Dim Ptr1 As Integer             'Points to edit window in a string
   Dim Ptr2 As Integer             'Position of cursor inside of window
   Dim k As Integer
   Dim m As Integer
   Dim s As String
   Dim LeftChunk As String
   Dim RightChunk As String
   Dim InitEdit As String

   InitEdit = Edit
   OldX = Pos(0)
   OldY = Csrlin
   Vis = Pbvcursorvis
   Sl1 = Pbvcursor1
   Sl2 = Pbvcursor2

   OldColor = Screen(y, x, 1)
   ScrColor = pbvScrnTxtAttr
   Color 15, 4

   If Mlen < n Then
     Print "Error. MaxLen < n. fEditLine"
     Exit Function
   End If

   Ptr1 = 1                       'Position of edit window
   Ptr2 = 1                       'Cursor position in edit window
   Do

     If Len(Edit) <> Mlen Then
       Edit = Left$(Edit + Space$(Mlen), Mlen)
     End If

     If Ptr2 < 1 Then
       Ptr2 = 1
       Decr Ptr1
     End If

     If Ptr2 > n Then
       Ptr2 = n
       Incr Ptr1
     End If

     If Ptr1 < 1 Then
       Ptr1 = 1
     End If

     If Ptr1 > Len(Edit) - n + 1 Then
       Ptr1 = Len(Edit) - n + 1
     End If

     Locate y, x, 0
     Print Mid$(Edit, Ptr1, n)

     If Ins = 0 Then
       Locate y, x + Ptr2 - 1, 1, 7, 8
     Else
       Locate y, x + Ptr2 - 1, 1, 5, 8
     End If

     k = fGetKey()

     Select Case k
     Case %ESC_key
       Function = InitEdit
       Abort = -1
       Exit Loop
     Case %ENTER_key
       Function = Edit
       Abort = 0
       Exit Loop
     Case %INS_key
       Ins = Ins Xor 1
     Case %HOME_key
       Ptr1 = 1
       Ptr2 = 1
     Case %END_key
       Ptr1 = Len(Edit) - n + 1
       Ptr2 = n
     Case %LEFT_key
       Decr Ptr2
     Case %RIGHT_key
       Incr Ptr2
     Case %DEL_key
       LeftChunk = Left$(Edit, Ptr1 + Ptr2 - 2)
       RightChunk = Mid$(Edit, Ptr1 + Ptr2)
       Edit = LeftChunk + RightChunk
     Case %BCSP_key
       If Ptr1 + Ptr2 < 3 Then Exit Select
       LeftChunk = Left$(Edit, Ptr1 + Ptr2 - 3)
       RightChunk = Mid$(Edit, Ptr1 + Ptr2 - 1)
       Edit = LeftChunk + RightChunk
       Decr Ptr2
     Case 31 To 255
       If Ptr1 + Ptr2 > 2 Then
         LeftChunk = Left$(Edit, Ptr1 + Ptr2 - 2)
       Else
       End If
       RightChunk = Mid$(Edit, Ptr1 + Ptr2 - Ins)
       Edit = LeftChunk + Chr$(k) + RightChunk
       Incr Ptr2
     End Select

   Loop

   Qfill x, y, x + n - 1, y, OldColor, 0
   Locate Oldy, OldX, Vis, Sl1, Sl2
   pbvScrnTxtAttr = ScrColor

 End Function
'---------------------------------------------------------------------------
 Function fGetMenu(T() As String, _
                  Byval Hed As String, _
                  Byval xb As Integer, _    'Up left
                  Byval yb As Integer, _    'corner location,
                  Byval wa As Integer, _    'Window`s attribute,
                  Byval ba As Integer, _    'Cursor`s attribute,
                  Byval Init As Integer _   'Initial cursor location.
                  ) As Integer

   Dim CurPos As Integer
   Dim OldPos As Integer
   Dim a As String
   Dim b As String
   Dim i As Integer
   Dim k As Integer
   Dim MaxPos As Integer
   Dim xe As Integer
   Dim ye As Integer

   CurPos = Init
   OldPos = CurPos
   k = 0
   For i = 1 To Ubound(T())
     If T(i) = "" Then Exit
     If Len(T(i)) > k Then k = Len(T(i))
   Next
   If Len(Hed) > k Then k = Len(Hed)
   xe = xb + k + 3
   ye = yb + i
   MakeWindow 1, xb, yb, xe, ye, wa, ba
   a = Chr$(Screen(yb + 1, xb))
   b = Chr$(Screen(yb + 1, xe))
   Rprint xb + 2, yb, Hed, 12
   For i = 1 To Ubound(T())
     Qprint xb + 2, yb + i, T(i)
     If T(i) = "" Then Exit
   Next
   MaxPos = i - 1

   Do
     Gosub ShowCursor
     OldPos = CurPos
     k = fGetKey()
     Select Case k
     Case %ESC_key
       CurPos = 0
       Exit
     Case %ENTER_key
       Exit
     Case %UP_key
       If CurPos > 1 Then
         Decr CurPos
       Else
         CurPos = MaxPos
       End If
     Case %DOWN_key
       If CurPos < MaxPos Then
         Incr CurPos
       Else
         CurPos = 1
       End If
     Case %END_key, %PGDN_key
       CurPos = MaxPos
     Case %HOME_key, %PGUP_key
       CurPos = 1
     End Select
   Loop

   Function = CurPos
   RemoveWindow
   Exit Function

   ShowCursor:
   Qprint xb, yb + OldPos, a
   Qprint xe, yb + OldPos, b
   Qfill xb, yb + OldPos, xe, yb + OldPos, wa, 0
   Qprint xb, yb + CurPos, Chr$(16)
   Qprint xe, yb + CurPos, Chr$(17)
   Qfill xb, yb + CurPos, xe, yb + CurPos, ba, 0
   Return

 End Function
'---------------------------------------------------------------------------
' Procedurec MakeWindow and RemoveWindow are similar to old TBWINDO
' utility (Turbo Basic programs for IBM PC/XT/AT compatibles), which
' creates multi-level windows. I'v taken only idea from it`s author.
'
 Sub MakeWindow(Byval t As Integer, _
   Byval xb As Integer, _
   Byval yb As Integer, _
   Byval xe As Integer, _
   Byval ye As Integer, _
   Byval wa As Integer, _         'Window`s attribute
   Byval sh As Integer _
   ) Public

   Incr WinPtr
   SaveWindow Wins(WinPtr), xb, yb, xe, ye, sh
   Windo t, xb, yb, xe, ye, wa, sh
   Wins(WinPtr) = Chr$(xb, yb) + Wins(WinPtr)

 End Sub
'---------------------------------------------------------------------------
 Sub RemoveWindow()

   Dim xb As Integer
   Dim yb As Integer

   If WinPtr < 1 Then Exit Sub
   xb = Asc(Mid$(Wins(WinPtr), 1, 1))
   yb = Asc(Mid$(Wins(WinPtr), 2, 1))
   RestoreWindow Mid$(Wins(WinPtr), 3), xb, yb
   Wins(WinPtr) = ""
   Decr WinPtr

 End Sub
'---------------------------------------------------------------------------
 Sub Windo(Byval t As Integer, _
   Byval xb As Integer, _
   Byval yb As Integer, _
   Byval xe As Integer, _
   Byval ye As Integer, _
   Byval wa As Integer, _         'Window`s attribute
   Byval sh As Integer _
   ) Public

   Dim a As Integer
   Dim b As Integer
   Dim c As Integer
   Dim d As Integer
   Dim e As Integer
   Dim f As Integer
   Dim g As Integer
   Dim h As Integer

   If t = 11 And Bit(Pbvscrncard, 4) = 0 Then t = 1

   Select Case t                  ' Window types:
   Case 1
     a = 218: b = 196: c = 191    'ÚÄÄÄÄÄÄÄ¿
     h = 179:        : d = 179    '³   1   ³
     g = 192: f = 196: e = 217    'ÀÄÄÄÄÄÄÄÙ
   Case 2
     a = 201: b = 205: c = 187    'ÉÍÍÍÍÍÍÍ»
     h = 186:          d = 186    'º   2   º
     g = 200: f = 205: e = 188    'ÈÍÍÍÍÍÍͼ
   Case 3
     a = 176: b = a: c = a        '°°°°°°°°°
     h = a:          d = a        '°   3   °
     g = a:   f = a: e = a        '°°°°°°°°°
   Case 4
     a = 177: b = a: c = a        '±±±±±±±±±
     h = a:          d = a        '±   4   ±
     g = a:   f = a: e = a        '±±±±±±±±±
   Case 5
     a = 219: b = 223: c = a      'ÛßßßßßßßÛ
     h = a:            d = a      'Û   5   Û
     g = a:   f = 220: e = a      'ÛÜÜÜÜÜÜÜÛ
   Case 6
     a = 213: b = 205: c = 184    'ÕÍÍÍÍÍÍ͸
     h = 179:          d = 179    '³   6   ³
     g = 212: f = 205: e = 190    'ÔÍÍÍÍÍÍ;
   Case 7
     a = 214: b = 196: c = 183    'ÖÄÄÄÄÄÄÄ·
     h = 186:          d = 186    'º   7   º
     g = 211: f = 196: e = 189    'ÓÄÄÄÄÄÄĽ
   Case 8
     a = 218: b = 196: c = 183    'ÚÄÄÄÄÄÄÄ·
     h = 179:          d = 186    '³   8   º
     g = 212: f = 205: e = 188    'ÔÍÍÍÍÍÍͼ
   Case 9
     a = 194: b = 196: c = 194    'ÂÄÄÄÄÄÄÄÂ
     h = 179:          d = 179    '³   9   ³
     g = 192: f = 196: e = 217    'ÀÄÄÄÄÄÄÄÙ
   Case 10
     a = 203: b = 205: c = 203    'ËÍÍÍÍÍÍÍË
     h = 186:          d = 186    'º   10  º
     g = 200: f = 205: e = 188    'ÈÍÍÍÍÍÍͼ
   Case 11
     a = 195: b = 196: c = 180    'ÃÄÄÄÄÄÄÄ´
     h = 179:          d = 179    '³   11  ³
     g = 192: f = 196: e = 217    'ÀÄÄÄÄÄÄÄÙ
   Case Else
     a = 032: b = a: c = a        '
     h = a:          d = a        ' Blanks only
     g = a:   f = a: e = a        '
   End Select

   Qfill xb, yb, xe, ye, wa, 32   ' Color of window

   qfill xb, yb, xe, yb, 0, b     ' Lines
   qfill xe, yb, xe, ye, 0, d     '
   qfill xb, ye, xe, ye, 0, f     '
   qfill xb, yb, xb, ye, 0, h     '

   qfill xb, yb, xb, yb, 0, a     ' Corners
   qfill xe, yb, xe, yb, 0, c     '
   qfill xe, ye, xe, ye, 0, e     '
   qfill xb, ye, xb, ye, 0, g     '

   Select Case sh
   Case 0                         'No shadow
   Case Else                      'Shadow
     qfill xe + 1, yb + 1, xe + 1, ye + 1, &H0008, 0
     qfill xb + 1, ye + 1, xe + 1, ye + 1, &H0008, 0
   End Select

 End Sub
'---------------------------------------------------------------------------
 Sub SaveWindow(W As String, _
   Byval Xb As Integer, _
   Byval Yb As Integer, _
   Byval Xe As Integer, _
   Byval Ye As Integer, _
   Byval sh As Integer) Public

   Dim Lx As Integer
   Dim Ly As Integer
   Dim Offset As Integer
   Dim i As Integer

'     Mouse_Hide
   Lx = (Xe - Xb + 1) * 2         'Bytes in row (including attrib bytes)
   Ly = Ye - Yb + 1               'Bytes in colomn
   If Sh Then                     'If need shadow
     Incr Lx, 2
     Incr Ly
   End If
   W = Chr$(Lx) + Space$(Lx * Ly)
   Offset = (Yb - 1) * 160 + (Xb - 1) * 2
   Def Seg = fGetScrnSeg
   For i = 1 To Ly
     Mid$(W,(i - 1) * Lx + 2) = Peek$(Offset + (i - 1) * 160, Lx)
   Next
   Def Seg
'     Mouse_Show

 End Sub
'---------------------------------------------------------------------------
 Sub RestoreWindow(Byval W As String, _
   Byval Xb As Integer, _
   Byval Yb As Integer) Public

   Dim Lx As Integer
   Dim Offset As Integer
   Dim i As Integer

   If W = "" Then Exit Sub
'     Mouse_Hide
   Lx = Ascii(W)
   Offset = (Yb - 1) * 160 + (Xb - 1) * 2
   Def Seg = fGetScrnSeg
   For i = 1 To(Len(W) - 1) \ Lx
     Poke$ Offset + (i - 1) * 160, Mid$(W,(i - 1) * Lx + 2, Lx)
   Next
   Def Seg
'     Mouse_Show

 End Sub
'---------------------------------------------------------------------------
 Function fGetScrnSeg() Public As Integer

   If (Pbvscrncard And 1) = 0 Then
     Function = &HB800              ' color monitor
   Else
     Function = &HB000              ' mono monitor
   End If

 End Function
'---------------------------------------------------------------------------
 Sub QFill(Byval xb As Integer, _
   Byval yb As Integer, _
   Byval xe As Integer, _
   Byval ye As Integer, _
   Byval Attr As Integer, _
   Byval FillChar As Integer _
   ) Public

   Dim ScrnSeg As Word

   ScrnSeg = fGetScrnSeg()


   ! push  ds                     ;save the good stuff
   ! push  di                     ;because we're gonna destroy it
   ! push  si

   ! mov   cx,ye                  ;calculate the number of times to iterate
   ! inc   cx
   ! sub   cx,yb

   ! mov   ax,yb                  ;put top of window into AX
   ! mov   dl,160                 ;put 160 into dl
   ! mul   dl                     ;multiply ax by 160 (Mul only multiplies AX)
   ! sub   ax,160                 ;subtract 160 from ax
   ! push  ax                     ;save it
   ! mov   ax,xb                  ;put top horizontal position into ax
   ! mov   dl,2                   ;put 2 into dl
   ! mul   dl                     ;multiply ax by 2 (mul only works on AX)
   ! mov   bx,ax                  ;put horizontal offset into bx
   ! pop   ax                     ;put vertical into ax
   ! add   ax,bx                  ;add them together
   ! dec   ax
   ! dec   ax                     ;and subtract 2
   ! push  ax                     ;push the value
   ! pop   di                     ;pop it into di register
   ! push  ax                     ;push it again for later <<<<<<<<<<<<<
'                                 'we'll add 160 to it and iterate
   ! mov   ax,ScrnSeg             ;and put video segment into ax
   ! push  ax                     ;and push it
   ! pop   es                     ;and pop it into es

   ! mov   bh,attr                ;the color attribute will be needed
   ! mov   bl,fillchar            ;the character for filling

   forloop1:                      'cx=number of lines.
   ! push  cx                     ;this is for looping how many lines
   ! mov   cx,xe                  ;calc the width of the window to
   ! inc   cx
   ! sub   cx,xb                  ;find out how many times to iterate

   forloop2:                      'a label for looping
   ! cmp   bl,0                   ;is our fillchar 0?
   ! je    doattr                 ;don't replace the screen char if it is
   ! mov   es:[di],bl             ;put the character into video ram

   doattr:
   ! inc di                       ;increment the di pointer
   ! cmp bh,0                     ;is the attribute 0?
   ! je         noattr                   ;don't change screen if it is
   ! mov es:[di],bh               ;poke the attribute into vidram

   noattr:
   ! inc di                       ;increment to the next vidram position
   ! loop forloop2                ;loop until cx=0
   ! pop cx                       ;go to the next loop level
   ! pop ax                       ;get the original write position
   ! add ax,160                   ;add bytes to get the next screen line
   ! push ax                      ;push it
   ! pop di                       ;pop a new di pointer for the screen
   ! push ax                      ;push it back for later
   ! loop forloop1                ;and iterate to the next

   ! pop ax                       ;clean up

   ! pop si                       ;restore the good stuff
   ! pop di
   ! pop ds

 End Sub
'---------------------------------------------------------------------------
  SUB Qprint(BYVAL Hor As Integer, _
            BYVAL ver As Integer, _
            A As String _
            ) PUBLIC

     Dim ScrSeg As Word

     If Len(A) = 0 Then Exit Sub

     ScrSeg = fGetScrnSeg
'
  !        push       ds          ;save the good stuff
  !        push       di          ;because we're gonna destroy it
  !        push       si
  !        mov        ax,ver      ;put vertical position into ax
  !        mov        dl,160      ;put 160 into dl
  !        mul        dl          ;multiply ax by 160 (Mul only multiplies AX)
  !        sub        ax,160      ;subtract 160 from ax
  !        push       ax          ;save it
  !        mov        ax,Hor      ;put horizontal position into ax
  !        mov        dl,2        ;put 2 into dl
  !        mul        dl          ;multiply ax by 2 (mul only works on AX)
  !        mov        bx,ax       ;put horizontal offset into bx
  !        pop        ax          ;put vertical into ax
  !        add        ax,bx       ;add them together
  !        dec        ax
  !        dec        ax          ;and subtract 2
  !        push       ax          ;push the value
  !        pop        di          ;pop it into di register
  !        mov        ax,ScrSeg   ;and put video segment into ax
  !        push       ax          ;and push it
  !        pop        es          ;and pop it into es
  !        lds        si,a        ;get the address if a's handle
  !        mov        ax,ds:[si]  ;put the handle into ax
  !        push       ax          ;push the handle
  !        call       GetStrLoc   ;find the location of the string
  !        push       ax          ;push the offset
  !        push       dx          ;push the segment
  !        pop        ds          ;pop the segment
  !        pop        si          ;pop the offset (cx already contains length)
'

forloop:                          'a label for looping
  !        mov        al,ds:[si]  ;get a character from the string
  !        mov        es:[di],al  ;put the character into video ram
  !        inc        di          ;increment the di pointer
  !        inc        di          ;increment to the next vidram position
  !        inc        si          ;increment to the next string position
  !        loop       forloop     ;loop until cx=0
  !        pop        si          ;restore the good stuff
  !        pop        di
  !        pop        ds

  END SUB
'---------------------------------------------------------------------------
' Does not change background color
 Sub Rprint( _
     Byval x As Integer, _
     Byval y As Integer, _
     Byval s As String, _
     Byval c As Integer _         'Foreground color
     )
   Dim OldX As Integer
   Dim OldY As Integer
   Dim Vis As Integer
   Dim Sl1 As Integer
   Dim Sl2 As Integer
   Dim Attr As Integer
   Dim Oa As Integer

   OldX = Pos(0)
   OldY = Csrlin
   Vis = Pbvcursorvis
   Sl1 = Pbvcursor1
   Sl2 = Pbvcursor2
   Oa = pbvScrnTxtAttr
   pbvScrnTxtAttr = (Screen(y, x, 1) And &HF0) Or c
   Locate y, x
   Print s
   pbvScrnTxtAttr = Oa
   Locate Oldy, OldX, Vis, Sl1, Sl2

 End Sub
'---------------------------------------------------------------------------
 Function fGetKey() As Integer

   While Inkey$ <> "": Wend       'Clear keyboad buffer
   While Not Instat: Qprint 72, 25, Time$: Wend
   Function = Cvi(Inkey$ + Chr$(0))

 End Function
'---------------------------------------------------------------------------
'----------------------------< END OF FILE >--------------------------------