'===========================================================================
' Subject: PRINT SOURCE CODE LISTING          Date: Year of 1993           
'  Author: Jane Griscti                       Code: QB, QBasic, PDS        
'  Origin: Night Owl v10 CD-ROM             Packet: MISC.ABC
'===========================================================================
'****************************************************************************
'* QBLISTER.BAS  Program prints QBasic or QuickBasic source code listings.
'*               The output is formatted at 12cpi with a left margin, page
'*               breaks, title, and numbers.
'*               Lines which exceed 96 chrs are broken at logical points.
'*               The user can select:
'*                  a file from any drive or directory.
'*                  to print a complete, continuous listing
'*                  to print a full listing with subs and functions
'*                    printed on seperate pages, or
'*                  to print only one sub or function
'*
'*               Limitations: File read must be in ASCII
'*                            No way to intercept DOS drive access errors
'*                            No way to access print spooler
'*                    
'*               Usage Notes: Printer codes are for IBM/Epson compatibles
'*                            See PrintFile Sub-routine
'* Jane Griscti (c) 1993
'*  jgriscti@vnet.ibm.com  or jane.griscti@canrem.com
'****************************************************************************
DEFINT A-Z

'******************************************
'*            Type Definitions            *
'******************************************
TYPE Lst
	Choice  AS INTEGER              'index of currently selected item
	LCol    AS INTEGER              'Starting column
	MaxLen  AS INTEGER              'width of list
	Rows    AS INTEGER              'number of rows to be displayed
	TopRow  AS INTEGER              'starting display line
	CurRow  AS INTEGER              'screen row of current selection
	TopEl   AS INTEGER              'first array element to be displayed
END TYPE

'******************************************
'*  SubRoutine and Function Declarations  *
'******************************************
DECLARE SUB Backdrop (TitleColor)
DECLARE SUB BoxSL (TRRow, TRCol, BRRow, BRCol, Shadow, Title$)
DECLARE SUB CleanUp (OldDrv$, OldDir$)
DECLARE SUB DrawScreen1 ()
DECLARE SUB DrawScreen2 ()
DECLARE SUB GetCurrPath ()
DECLARE SUB GetDirNames (CurrDir$)
DECLARE SUB GetFiles (CurrDir$)
DECLARE SUB InitDrvs ()
DECLARE SUB InitDirs ()
DECLARE SUB InitFiles ()
DECLARE SUB InitSubsFuncs ()
DECLARE SUB PrintFile (FileName$, SepPages, SearchName$)
DECLARE SUB PrintHeader (Margin, Header$, Lines, PageNo)
DECLARE SUB ScrollLst (Array$(), Table AS Lst, Action%, Wnd%)
DECLARE SUB SelectDrv (Wnd)
DECLARE SUB SelectDir (Wnd)
DECLARE SUB SelectFile (FileName$)
DECLARE FUNCTION Answer% (Prompt$)
DECLARE FUNCTION LastEl% (a$())


'******************************************
'*     Define Variables and Arrays        *
'******************************************
COMMON SHARED FGColor AS INTEGER, BGColor AS INTEGER, OldColor AS INTEGER
COMMON SHARED CurrDir AS STRING, CurrDrv AS STRING
REDIM SHARED DirNames$(50), FileNames$(100), Funcs$(50), Subs$(50)
DIM SHARED DrvLst AS Lst, FileLst AS Lst, DirLst AS Lst, DrvNames$(5)
DIM SHARED SubLst AS Lst, FuncLst AS Lst

' --------- Fill DrvNames$ array
DrvNames$(1) = " [ A ]"
DrvNames$(2) = " [ B ]"
DrvNames$(3) = " [ C ]"
DrvNames$(4) = " [ D ]"
DrvNames$(5) = " [ E ]"

'******************************************
'*      Set up Error Handler              *
'******************************************
ON ERROR GOTO CheckError                    'if error goto this label


'******************************************
'*       Initialize and draw the screen   *
'******************************************
WIDTH 80, 25: SCREEN 0                  'set screen page and size
OldColor = SCREEN(CSRLIN, POS(0), -1)   'save original screen colors
ENVIRON "DIRCMD="                       'make sure no /P(AUSE) in dir command
FGColor = 8                             'foreground color - grey
BGColor = 3                             'bacground color - cyan
COLOR FGColor, BGColor                  'set colors
CLS                                     'clear screen
CALL GetCurrPath                        'get default drive and directory
CALL DrawScreen1                        'Draw display screen
OldDrv$ = CurrDrv$                      'save original drive
OldDir$ = CurrDir$                      'save original directory

' ---------- Initialize lists
CALL InitDrvs
CALL InitDirs
CALL InitFiles
CALL InitSubsFuncs
		 
' ---------- Display default directory and files
DrvLst.Choice = ASC(CurrDrv$) - 65 + 1      'select current drive as default
CALL ScrollLst(DrvNames$(), DrvLst, 1, 1)
CALL GetDirNames(CurrDir$)
CALL ScrollLst(DirNames$(), DirLst, 1, 2)
CALL GetFiles(CurrDir$)
CALL ScrollLst(FileNames$(), FileLst, 1, 3)


'******************************************
'*          Main loop                     *
'******************************************
Wnd = 3                                 'set FileNames as active Window

DO WHILE Wnd <> -1
   SELECT CASE Wnd
	  CASE 1
	CALL ScrollLst(DrvNames$(), DrvLst, 0, Wnd)
	  CASE 2
	CALL ScrollLst(DirNames$(), DirLst, 0, Wnd)
	  CASE 3
	CALL ScrollLst(FileNames$(), FileLst, 0, Wnd)
	  CASE 4
	CALL ScrollLst(Funcs$(), FuncLst, 0, Wnd)
	  CASE 5
	CALL ScrollLst(Subs$(), SubLst, 0, Wnd)
	  CASE 10
	CALL DrawScreen1
	CALL SelectDrv(Wnd)
	CALL ScrollLst(DrvNames$(), DrvLst, 1, 1)
	CALL ScrollLst(DirNames$(), DirLst, 1, 2)
	CALL ScrollLst(FileNames$(), FileLst, 1, 3)
	 
	  CASE 20
	CALL SelectDir(Wnd)
	CALL ScrollLst(DrvNames$(), DrvLst, 1, 1)
	CALL ScrollLst(DirNames$(), DirLst, 1, 2)
	CALL ScrollLst(FileNames$(), FileLst, 1, 3)

	  CASE 30
	' ------ Setup Filename
	FileName$ = FileNames$(FileLst.Choice)

	' ------ Make sure selected file is in ASCII
	OPEN FileName$ FOR INPUT AS #1
	LINE INPUT #1, LineBuffer$
	CLOSE #1
	   
	Char$ = LEFT$(LineBuffer$, 1)
	CharVal = ASC(Char$)

	IF CharVal = 252 THEN                   'file is in Binary format
	  CALL Backdrop(0)
	  COLOR 7, 4
	  CALL BoxSL(10, 8, 15, 72, 1, "")
	  COLOR 7, 4
	  LOCATE 12, 10
	  PRINT FileName$; " is a binary file...please select an ASCII file"
	  LOCATE 13, 27
	  PRINT "Press any key to continue..."
	  BEEP: BEEP
	  WHILE INKEY$ = "": WEND
	  COLOR FGColor, BGColor
	  CLS
	  Wnd = 10
	END IF
	   
	IF Wnd <> 10 THEN               ' OK, file is ASCII
	  ' ------ Find out if user wants to print complete file
	  CALL Backdrop(0)
	  CALL BoxSL(9, 15, 13, 70, 1, "")
	  LOCATE 11, 18
	  IF Answer%("Print entire file?") THEN
		LOCATE 12, 18
		IF Answer%("Print FUNCTIONS and SUBS on seperate pages?") THEN
		  SepPages = 1
		ELSE
		  SepPages = 0
		END IF
		Wnd = 60
	  ELSE
		CALL SelectFile(FileName$)
		CALL DrawScreen2
		CALL ScrollLst(Funcs$(), FuncLst, 1, 4)
		CALL ScrollLst(Subs$(), SubLst, 1, 5)
		Wnd = 5
	  END IF
	END IF

	  CASE 40, 50, 60
	IF Wnd = 40 THEN
	  SearchName$ = "FUNCTION " + Funcs$(FuncLst.Choice)
	ELSEIF Wnd = 50 THEN
	  SearchName$ = "SUB " + Subs$(SubLst.Choice)
	ELSE
	  SearchName$ = ""
	END IF
	   
	CALL PrintFile(FileName$, SepPages, SearchName$)
	   
	Wnd = 10                      'go back to drv,dir,filename display
	
	 END SELECT
LOOP
 
CALL CleanUp(OldDrv$, OldDir$)                  'reset orig colors,dir

END                                             'end program

'----------- Error handling routine

CheckError:
	'----------- Printer not on
	IF ERR = 25 THEN
	   LOCATE 20, 25
	   COLOR 7, 4                      ' set colors to red and white
	   PRINT "Please turn on your printer"
	   COLOR FGColor, BGColor
	   RESUME
	END IF
	 

	'----------- Input past end of file
	IF ERR = 62 THEN
	   EmptyFile = 1
	   FileNames$(1) = " < No Files Found >"
	   RESUME NEXT
	END IF

		 
	'----------- Unexpected error
	COLOR 7, 4                          'set colors to red and white
	BEEP                                'make a noise to alert user
	LOCATE 23, 20
	PRINT "Unexpected Error: "; ERR;    'print error message
	PRINT "Press any key to End."
	CLOSE                               'force close of any open files
	WHILE INKEY$ = "": WEND             'pause to read message
	CALL CleanUp(OldDrv$, OldDir$)      'reset orig colors, dir
	END                                 'exit program

FUNCTION Answer% (Prompt$)
'***************************************************************************
'* FUNCTION:            Answer
'*
'* PARAMETERS:          Prompt$    Question to be asked
'***************************************************************************

' ------ Ask the question
PRINT Prompt$; " (Y/N)"

' ------ Wait for Y or N to be pressed
DO
  Ky$ = INKEY$
  IF LEN(Ky$) AND INSTR("YyNn", Ky$) > 0 THEN EXIT DO
LOOP

' ------ Return 0 for N, Non-zero for Yes
Answer% = INSTR("Yy", Ky$)

END FUNCTION

SUB Backdrop (TitleColor)
'****************************************************************************
'* SUB FUNCTION:    Backdrop
'*                  Draws the background screen by repeating a pattern of
'*                  characters.  Places a title on the bottom screen row.
'* PARAMETERS:      TitleColor  - color to use for printing screen title
'****************************************************************************

LOCATE 1, 17                    'position cursor
COLOR TitleColor, BGColor       'print title in black instead of grey
PRINT "QBasic or QuickBasic Source Code Print Utility";
COLOR FGColor, BGColor
PRINT STRING$(1840, 177);       'fill the screen with CHR$(177)
LOCATE 25, 1                    'locate cursor
PRINT "QBLISTER  v1.00, (c) 1993, Jane Griscti";

END SUB

SUB BoxSL (TLRow, TLCol, BRRow, BRCol, Shadow, Title$) STATIC
'****************************************************************************
'* SUB FUNCTION:    BoxSL
'*                  Draws a solid box with a single line border, an
'*                  optional shadow and title.  Parameters define top left
'*                  and bottom right corners of box to be drawn.
'*
'* PARAMETERS:      TLRow       Top Left Row coordinate
'*                  TLCol       Top Left Column coordinate
'*                  BRRow       Bottom Right Row coordinate
'*                  BRCol       Bottom Right Column coordinate
'*                  Shadow      0 = do not draw shadow
'*                              1 = draw shadow
'*                  Title$      Blank string = no title
'*
'****************************************************************************

	LOCATE TLRow, TLCol             'position cursor

	'----- Draw the top of the box
	PRINT CHR$(218) + STRING$(BRCol - TLCol - 1, 196) + CHR$(191);

	'----- Print the title
	IF Title$ <> "" THEN                            'if string is not empty
	  IF LEN(Title$) < (BRCol - TLCol + 2) THEN     'if string not too long
		LOCATE TLRow, TLCol + 1                     'position cursor
		PRINT CHR$(60) + Title$ + CHR$(62)          'print title string
	  END IF
	END IF

	'----- Draw the middle of the box
	FOR i = TLRow + 1 TO BRRow - 1
	  LOCATE i, TLCol
	  PRINT CHR$(179) + STRING$(BRCol - TLCol - 1, 32) + CHR$(179);
	NEXT

	'----- Draw the bottom of the box
	LOCATE BRRow, TLCol
	PRINT CHR$(192) + STRING$(BRCol - TLCol - 1, 196) + CHR$(217);

	
	IF Shadow THEN                      'if Shadow flag = 1 then
					' draw right side of shadow
	FOR i = TLRow + 1 TO BRRow          'top of loop
	  Clr = SCREEN(i, BRCol + 1, 1)     'Get existing screen color
	  COLOR 0, Clr \ 16                 'Use hi byte for background color
	  LOCATE i, BRCol + 1               'Position the cursor
	  PRINT CHR$(177) + CHR$(177);      'Print Shadow character
	NEXT                                'bottom of loop
					' draw bottom shadow
	FOR i = TLCol + 2 TO BRCol + 2      'top of loop
	  Clr = SCREEN(BRRow + 1, i, 1)     'get existing screen color
	  COLOR 0, Clr \ 16                 'use hi byte for background color
	  LOCATE BRRow + 1, i               'position cursor
	  PRINT CHR$(177);                  'print shadow character
	NEXT                                'bottom of loop

	END IF                              'end of shadow drawing

END SUB                                 'exit this routine

SUB CleanUp (OldDrv$, OldDir$)
'***************************************************************************
'* SUB:         CleanUp
'*                Resets the system to original colors, drive and directory
'*
'* PARAMETERS:  OldDrv$     Original Drive letter
'*              OldDir$     Original Directory Name
'***************************************************************************

CLOSE                                   ' make sure all files are closed
COLOR OldColor AND 15, OldColor \ 16
CLS
DosCom$ = OldDrv$ + ":"
SHELL DosCom$
DosCom$ = "cd " + OldDir$
SHELL DosCom$

END SUB

SUB DrawScreen1
'***************************************************************************
'* SUB FUNCTION:        DrawScreen1
'*                      Draws the initial display screen
'* PARAMETERS:          None
'***************************************************************************

CALL Backdrop(0)                        'draw background grey, cyan
CALL BoxSL(3, 5, 6, 75, 1, "")          'draw Instructions Box
LOCATE 4, 6                             'position cursor
PRINT "   [TAB] - Move between windows" 'print instruction
LOCATE 5, 6                             'position cursor
PRINT "[Arrows] - Highlight selection"  'print instruction
LOCATE 4, 40                             'position cursor
PRINT "[ENTER] - Accept selection"       'print instruction
LOCATE 5, 40                            'position cursor
PRINT "  [ESC] - EXIT"                  'display instruction

CALL BoxSL(9, 5, 15, 20, 1, "Drives")   'draw Drive List Box

CALL BoxSL(17, 5, 20, 20, 1, "Directory")  'draw Curr Dir box
LOCATE 17, 6

CALL BoxSL(9, 25, 22, 45, 1, "Sub-Directories")'draw Directory List Box
LOCATE 9, 26                            ' position cursor

CALL BoxSL(9, 50, 22, 75, 1, "Files")   'draw File List Box
LOCATE 9, 51                            'position cursor


END SUB

SUB DrawScreen2
'***************************************************************************
'* SUB:         DrawScreen2
'*              Draw screen for display of Sub-Routine and Function Names
'*
'***************************************************************************
CALL Backdrop(0)
CALL BoxSL(3, 5, 6, 71, 1, "")
LOCATE 4, 10
PRINT "[TAB] to move between windows               [ESC] to exit"
LOCATE 5, 10
PRINT "[ENTER] to select Function or Sub-routine"
CALL BoxSL(9, 5, 22, 35, 1, "Functions")
CALL BoxSL(9, 40, 22, 71, 1, "Sub-Routines")

END SUB

SUB GetCurrPath
'***************************************************************************
'* SUB:                 GetCurrPath
'*                         Gets the current path name
'* PARAMETERS:          None
'* SHARED VARIABLES:    CurrDir$
'*                      CurrDrv$
'***************************************************************************

  SHELL "dir *. > tmppath.dat"        'capture current dir info in file
  OPEN "tmppath.dat" FOR INPUT AS #1  'open file for input
  FOR i = 1 TO 4                      'loop to fourth line
  INPUT #1, x$                       'assign lines to temp variable
  NEXT i
  CLOSE 1
  Y = LEN(x$)                         'store the string length
  CurrDir$ = MID$(x$, 14, Y - 12)     'capture directory name
  CurrDrv$ = LEFT$(CurrDir$, 1)       'capture drive letter
  SHELL "del tmppath.dat"             'delete temporary file

END SUB

SUB GetDirNames (CurrDir$)
'***************************************************************************
' SUB ROUTINE:      GetDirNames
'*                  Displays the sub-directories assocated with current
'*                  directory and highlights the currently selected directory
'* PARAMETERS:      CurrDir$        Current directory
'***************************************************************************

IF LEN(CurrDir$) > 3 THEN
  '---------- Write subdirectory names to temp file
  DosCom$ = "dir " + CurrDir$ + "\*.  /on >tmpdir.dat"    'set up DOS command
  SHELL DosCom$                                           'run DOS
ELSE
  DosCom$ = "dir *. /on >tmpdir.dat"
  SHELL DosCom$
END IF

  '---------- Write names to an array, assumes no more than 50 dir names
  REDIM DirNames$(50)                        're-dimension array
  i = 0                                      'count variable
  OPEN "TMPDIR.DAT" FOR INPUT AS #1          'open file to read names

  DO                                         'start of DO loop
	INPUT #1, x$                           'assign name to array
	IF INSTR(1, x$, "<DIR>") THEN          'make sure it's a dir name
	   i = i + 1                           'increment counter
	   DirNames$(i) = LEFT$(x$, 8)         'if it is, save name array
	END IF
  LOOP WHILE NOT (EOF(1))                    'while not end of file

  CLOSE 1                                    'close file
  SHELL "del tmpdir.dat"                     'delete temporary file

' ------------ Put current dir name on screen
LOCATE 19, 8
PRINT SPACE$(12)                             'clear old name
IF LEN(CurrDir$) > 3 THEN
  x = LEN(CurrDir$)                          'length of current path
  Y = 1                                      'position indicator
  WHILE (Y < x) AND (Y <> 0)                 'begin search for "\"
	Y = INSTR(Y, CurrDir$, "\")              'assign positon of "\"
	IF (Y <> 0) THEN                         'match found
	mark = Y                               'save position of "\"
	Y = Y + 1                              'start next search
	END IF
  WEND
  LOCATE 19, 8
  PRINT RIGHT$(CurrDir$, x - mark)
ELSE                                         'you're in the root directory
  LOCATE 19, 8
  PRINT " [ROOT] "
END IF

END SUB

SUB GetFiles (CurrDir$)
'***************************************************************************
'* SUB ROUTINE:     GetFiles
'*                  Get the names of all files with the ".BAS" extension
'*                  in the current directory and store them in an array
'* PARAMETERS:      CurrDir$    Current path name
'***************************************************************************
SHARED EmptyFile
EmptyFile = 0

'---------- Write files names to temp file
IF LEN(CurrDir$) > 3 THEN
  DosCom$ = "dir " + CurrDir$ + "\*.bas /b /on >tmpfiles.dat"
ELSE
  DosCom$ = "dir *.bas /b /on >tmpfiles.dat"
END IF

SHELL DosCom$                              'run DOS command

'---------- Write names to an array, assumes no more than 100 file names
REDIM FileNames$(100)                      're-dimension array
i = 1                                      'count variable

OPEN "TMPFILES.DAT" FOR INPUT AS #1        'open file to read names
IF EmptyFile = 0 THEN
	DO                                         'do
		INPUT #1, FileNames$(i)                'assign name to array
		i = i + 1                              'increment counter
	LOOP WHILE NOT (EOF(1))                    'while not end of file
END IF

CLOSE 1                                    'close file

SHELL "del tmpfiles.dat"                   'delete temporary file

END SUB

SUB InitDirs
'**************************************************************************
'* SUB:         InitDirs
'*                Sets up starting values for Directory Scroll List
'*
'* PARAMETERS:  None
'* SHARED:      DirLst()
'**************************************************************************

DirLst.Choice = 1                   'starting array element
DirLst.LCol = 26                    'left column start position
DirLst.MaxLen = 19                  'width of list
DirLst.Rows = 12                    '# of display rows allowed
DirLst.TopEl = 1                    'first array element to be displayed
DirLst.TopRow = 10                  'starting display row
DirLst.CurRow = 1

END SUB

SUB InitDrvs
'***************************************************************************
'* SUB:         InitDrvs
'*                Sets up starting values for Drives Scroll List
'*
'* PARAMETERS:  None
'* SHARED:      DrvLst()
'***************************************************************************

DrvLst.Choice = 1                   'starting array element
DrvLst.LCol = 6                     'left column start position
DrvLst.MaxLen = 14                  'width of list
DrvLst.Rows = 5                     '# of display rows allowed
DrvLst.TopEl = 1                    'first array element to be displayed
DrvLst.TopRow = 10                  'starting display row
DrvLst.CurRow = 1

END SUB

SUB InitFiles
'***************************************************************************
'* SUB:         InitFiles
'*                Sets up starting values for Files Scroll List
'*
'* PARAMETERS:  None
'* SHARED:      FileLst()
'**************************************************************************

FileLst.Choice = 1                  'starting array element
FileLst.LCol = 51                   'left column start position
FileLst.MaxLen = 24                 'width of list
FileLst.Rows = 12                   '# of display rows allowed
FileLst.TopEl = 1                   'first array element to be displayed
FileLst.TopRow = 10                 'starting display row
FileLst.CurRow = 1

END SUB

SUB InitSubsFuncs
'***************************************************************************
'* SUB:         InitSubsFuncs
'*                Sets up starting values for Sub-routine and Function
'*                Scroll Lists
'*
'* PARAMETERS:  None
'* SHARED:      SubLst()
'*              FuncLst()
'****************************************************************************

' ---------- Initialize parameters for Sub-routine List

SubLst.Choice = 1                   'starting array element
SubLst.LCol = 41                    'left column start position
SubLst.MaxLen = 30                  'width of list
SubLst.Rows = 12                    '# of display rows allowed
SubLst.TopEl = 1                    'first array element to be displayed
SubLst.TopRow = 10                  'starting display row
SubLst.CurRow = 1

' ---------- Initialize parameters for Function List

FuncLst.Choice = 1                   'starting array element
FuncLst.LCol = 6                     'left column start position
FuncLst.MaxLen = 29                  'width of list
FuncLst.Rows = 12                    '# of display rows allowed
FuncLst.TopEl = 1                    'first array element to be displayed
FuncLst.TopRow = 10                  'starting display row
FuncLst.CurRow = 1

END SUB

FUNCTION LastEl% (a$()) STATIC
'**************************************************************************
'*  FUNCTION:       LastEl
'*                  Finds the last element in a string array
'*  PARAMETERS:     A$  Array being worked on
'**************************************************************************
FOR i = UBOUND(a$) TO 1 STEP -1             'start at the last element
  IF LEN(RTRIM$(a$(i))) THEN                'if it is not null
	LastEl% = i                             'assign function value
	EXIT FUNCTION
  END IF
NEXT                                        'otherwise keep looking

END FUNCTION

SUB PrintFile (FileName$, SepPages, SearchName$)
'**************************************************************************
'* SUB:         PrintFile
'*                Routine initializes the printer, opens the selected file
'*                reads, formats and prints each line.
'*
'* PARAMETERS:  FileName$       Name of file to be opened
'*              SepPages        Seperate page for subs/functions indicator
'*                              1 = print seperate pages
'*                              0 = do not print seperate pages
'*              SearchName$     Name of specific Sub or Function to be printed
'*                              Empty string means none selected
'**************************************************************************

   ' ------ Set up Page and Line counter variables
   PageNo = 0
   Lines = 0
		 
   ' ---------- Make sure printer is online
	CALL Backdrop(0)
	COLOR 7, 4                              'set color to red and white
	CALL BoxSL(9, 15, 15, 70, 1, "")
	COLOR 7, 4
	LOCATE 11, 17
	PRINT "Please ensure your printer is ON and READY for input"
	LOCATE 12, 17
	IF SearchName$ <> "" THEN
	  INPUT "Starting page number"; PageNo
	  IF PageNo > 0 THEN PageNo = PageNo - 1
	END IF
	LOCATE 13, 17
	PRINT "Press any key to continue ..."
	BEEP: BEEP
	WHILE INKEY$ = "": WEND
	COLOR FGColor, BGColor                  ' reset colors
						   

   ' ------------ Open file and initialize printer settings
	OPEN FileName$ FOR INPUT AS #1    ' open the file for input

	' *************************************************************
	' * CHANGE THESE CODES IF PRINTER IS NOT IBM/EPSON COMPATIBLE *
	' * OR TO CHANGE CHARACTER SIZE.                              *
	' * Note:  If you change CPI, reconfigure the page header as  *
	' *        it's predefined for 96 CPI.                        *
	' *************************************************************
	CPIChr = 58                       ' 58 = 12 cpi
	PrnLen = 96 - 1                   ' at 12cpi line length=96 chars
	FFChar = 12                       ' Form Feed Character
	TenCPI = 18                       ' 18 = 10 cpi
	ESCChr = 27                       ' ESC code
	LPRINT CHR$(ESCChr); CHR$(CPIChr) ' initialize printer
	'***************************************************************

	WIDTH LPRINT PrnLen + 1           ' set printer width for cpi
	Margin = 5                        ' left margin width
	Margin$ = STRING$(Margin, " ")    ' build margin string

   ' ------ Build page title and print first page header
	IF LEN(FileName$) < 12 THEN
	  FileName$ = FileName$ + STRING$(12 - LEN(FileName$), " ")
	END IF
	Header$ = " FILENAME: " + FileName$ + SPACE$(7) + "DATE: " + DATE$
	Header$ = Header$ + SPACE$(8) + "TIME: " + TIME$ + SPACE$(10) + "Page: "
   
	CALL PrintHeader(Margin, Header$, Lines, PageNo)
	   
	   
   ' ------ Get first line to be printed, if entire file was selected
   '        then first line of file = first print line, otherwise, find
   '        the first line of the selected SUB or FUNCTION
	   
	TestStr = LEN(SearchName$)
	LINE INPUT #1, LineBuffer$
	IF TestStr > 1 THEN
	  IF LEFT$(SearchName$, 8) <> "SUB MAIN" THEN
	    DO
	      IF LEFT$(LineBuffer$, TestStr) = SearchName$ THEN
		EXIT DO
	      END IF
	      LINE INPUT #1, LineBuffer$
	    LOOP UNTIL EOF(1)
	  END IF
	END IF


	  ' ------ Read each line in the file and print it

      DO UNTIL EOF(1)
	   
	Temp$ = Margin$ + LineBuffer$

	  rspc = 0                              'right space marker
	  Temp1$ = ""                           'temp string holder
	  Margin1$ = ""                         'multiple line margin
	
	  DO WHILE LEN(Temp$) > PrnLen
		' ------ Get the first portion of the string
		Temp1$ = RTRIM$(LEFT$(Temp$, PrnLen))

		' ------ Find the right most space
		i = 1
		DO WHILE i > 0
		  i = INSTR(rspc + 1, Temp1$, " ")
		  IF i > 0 THEN rspc = i
		LOOP
		
		' ------ Print the string portion
		IF Lines > 60 THEN
		  LPRINT CHR$(FFChar)
		  CALL PrintHeader(Margin, Header$, Lines, PageNo)
		END IF
		LPRINT LEFT$(Temp1$, rspc - 1)
		Lines = Lines + 1
	   
		' ------ Increase margin for multiple print lines
		Margin1$ = "  "
	   
		' ------ Assign remainder of original string to Temp$
		Temp$ = Margin$ + Margin1$ + RIGHT$(Temp$, LEN(Temp$) - rspc)

	  LOOP
	 
	  ' ------ Print short line or last portion of long line
	  IF Lines > 60 THEN
		LPRINT CHR$(FFChar)
		CALL PrintHeader(Margin, Header$, Lines, PageNo)
	  END IF
	  LPRINT Temp$
	  Lines = Lines + 1
	 
	 
	  LINE INPUT #1, LineBuffer$              'get the next line in file

	  ' ----------- If selected to print SUBS and FUNCTIONS on seperate
	  '             pages, check to see if a new one is encountered

	IF SepPages = 1 THEN
	  IF LEFT$(LineBuffer$, 3) = "SUB" OR LEFT$(LineBuffer$, 8) = "FUNCTION" THEN
	    LPRINT CHR$(FFChar)                     'issue Form Feed instruction
	    CALL PrintHeader(Margin, Header$, Lines, PageNo)
	  END IF
	END IF

	  
	  ' ----------- If printing a MAIN, SUB, or FUNCTION, exit loop when you
	  '             reach the end of the routine

      IF TestStr > 1 THEN
	IF INSTR(SearchName$, "MAIN MODULE") THEN
	  IF LEFT$(LineBuffer$, 3) = "SUB" OR LEFT$(LineBuffer$, 8) = "FUNCTION" THEN
	    CLOSE
	    LPRINT CHR$(FFChar)
	    LPRINT CHR$(TenCPI)
	    EXIT SUB
	  END IF
	END IF

	IF INSTR(LineBuffer$, "END SUB") OR INSTR(LineBuffer$, "END FUNCTION") THEN
	  EXIT DO
	END IF
      END IF

   LOOP
	 
   CLOSE                                     'close files
   LPRINT Margin$ + LineBuffer$              'print last line in file
   LPRINT CHR$(FFChar)                       'send final form feed
   LPRINT CHR$(TenCPI);                      'set printer back to 10cpi
END SUB

SUB PrintHeader (Margin, Header$, Lines, PageNo)
'***************************************************************************
'* SUB:         PrintHeader
'*                Prints the page title centered in a graphics box
'*
'* PARAMETERS:  Margin      left margin width
'*              Header$     title to be printed
'*              Lines       line counter
'*              PageNo      page counter
'***************************************************************************

PageNo = PageNo + 1                     ' increase page counter
Lines = 5                               ' reset line counter
LPRINT SPC(Margin); CHR$(201) + STRING$(88, 205) + CHR$(187)
LPRINT SPC(Margin); CHR$(186); Header$;
LPRINT USING "##"; PageNo;
LPRINT SPC(2); CHR$(186)
LPRINT SPC(Margin); CHR$(200) + STRING$(88, 205) + CHR$(188);
LPRINT : LPRINT

END SUB

SUB ScrollLst (Array$(), Table AS Lst, Action, Wnd)
'***************************************************************************
'* SUB ROUTINE:         ScrollLst
'*                      Routines allows scrolling through a list of array
'*                      names
'*
'* PARAMETERS:          Array$()    Array of items to be scrolled
'*                      Table       Parameters applied to array
'*                      Action      0  bypass initial display
'*                                  1  display and poll for keypress
'*                      Wnd         1  Drives Window
'*                                  2  Directory Window
'*                                  3  File Window
'*                                  4  Functions Window
'*                                  5  Sub-Routine Window
'*
'**************************************************************************

' ------ Set up parameters for list
TopRow = Table.TopRow                   ' start screen row for display
Rows = Table.Rows                       ' no. of rows to display
BotRow = Rows + TopRow - 1              ' bottom screen row of display
LastCh = Table.Choice                   ' current array element
LastCurRow = Table.CurRow               ' last array choice display row
Elements = LastEl%(Array$())            ' # of elements in Array$


' ------ Display the list

	' ------ Are there more display rows than elements?
	IF Rows > Elements THEN
	   Rows = Elements                  ' reduce displayed rows
	   FOR i = Rows TO Table.Rows       ' blank out extra rows
	  LOCATE i + TopRow - 1, Table.LCol
	  PRINT STRING$(Table.MaxLen, 32);
	   NEXT i
	END IF

	' ------ Are there more elements than display rows?
	IF Elements > Table.Rows AND Action = 0 THEN
	  LastPtrRow = BotRow
	  Ptr = -1
	  RSide$ = CHR$(176)
	  FOR i = 1 TO Rows
	LOCATE i + TopRow - 1, Table.LCol + Table.MaxLen
	PRINT RSide$;
	  NEXT i
	ELSE
	  RSide$ = CHR$(179)
	  Ptr = 0
	END IF
   
	GOSUB Scroll

IF Action = 0 THEN
  Ptr = -1
  LOCATE Table.CurRow, Table.LCol + Table.MaxLen
  PRINT CHR$(17);
END IF

DO WHILE Action = 0
  k$ = INKEY$
 
  SELECT CASE LEN(k$)
	CASE 0
	  KeyCode = 0
	  x = 0
	CASE 1
	  KeyCode = ASC(k$)
	CASE 2
	  KeyCode = ASC(RIGHT$(k$, 1))
  END SELECT

  SELECT CASE KeyCode
	CASE 27                             'ESC
	  IF Wnd = 4 OR Wnd = 5 THEN        'if in Subs/Func screen return to
	Wnd = 10                        'main screen
	  ELSE                              'else
	Wnd = -1                        '  exit program
	  END IF
	  EXIT SUB
	
	CASE 13                             'ENTER
	   
	' ------ Erase pointer in current window
	LOCATE LastCurRow, Table.LCol
	Temp$ = Array$(LastCh)
	Temp$ = Temp$ + SPACE$(Table.MaxLen - LEN(Temp$)) + CHR$(176)
	PRINT Temp$;
	 
	  IF Wnd = 1 THEN Wnd = 10          'based on active Window
	  IF Wnd = 2 THEN Wnd = 20          'select actions to follow
	  IF Wnd = 3 THEN Wnd = 30
	  IF Wnd = 4 THEN Wnd = 40
	  IF Wnd = 5 THEN Wnd = 50
	  EXIT SUB

	CASE 9                              'TAB

	' ------ Erase pointer in current window
	LOCATE LastCurRow, Table.LCol
	Temp$ = Array$(LastCh)
	Temp$ = Temp$ + SPACE$(Table.MaxLen - LEN(Temp$)) + CHR$(176)
	PRINT Temp$;
	 
	  IF Wnd = 1 THEN                  'based on active Window
	Wnd = 2                        ' move to next Window
	EXIT SUB
	  ELSEIF Wnd = 2 THEN
	Wnd = 3
	EXIT SUB
	  ELSEIF Wnd = 3 THEN
	Wnd = 1
	EXIT SUB
	  ELSEIF Wnd = 4 THEN
	Wnd = 5
	EXIT SUB
	  ELSEIF Wnd = 5 THEN
	Wnd = 4
	EXIT SUB
	  END IF

	CASE 72                             ' up  arrow
	  x = -1
	CASE 80                             ' down arrow
	  x = 1
  END SELECT

  ' ------ Handle the direction keys
  IF x THEN
	Table.Choice = Table.Choice + x

	' ------ Make sure choice is within array range
	IF Table.Choice > Elements THEN
	  BEEP
	  Table.Choice = Elements
	END IF
	IF Table.Choice < 1 THEN
	  BEEP
	  Table.Choice = 1
	END IF
	IF Table.Choice > Table.TopEl + Rows - 1 THEN
	  Table.TopEl = Table.TopEl + x
	END IF
	IF Table.Choice < LastCh AND Table.TopEl = LastCh THEN
	  Table.TopEl = Table.Choice
	END IF

	IF Table.Choice <> LastCh THEN
	  GOSUB Scroll
	END IF
  END IF
LOOP

EXIT SUB

Scroll:

' ------ Print array
LOCATE , , 0                            ' turn off the cursor

' ------ Determine the Current display row

Table.CurRow = TopRow + Table.Choice - Table.TopEl

FOR i = 1 TO Rows
  LOCATE TopRow + i - 1, Table.LCol
  Temp$ = Array$(Table.TopEl + i - 1)
  Temp$ = Temp$ + SPACE$(Table.MaxLen - LEN(Temp$))
  PRINT Temp$
NEXT i

' ------ If there's a pointer, display it
IF Ptr THEN
  
  ' ------ Erase the previous pointer, if the row is still in range
  LOCATE LastCurRow, Table.LCol
  Temp$ = Array$(LastCh)
  Temp$ = Temp$ + SPACE$(Table.MaxLen - LEN(Temp$)) + CHR$(176)
  PRINT Temp$;

  '------ Draw the new pointer
  LOCATE Table.CurRow, Table.LCol + Table.MaxLen
  PRINT CHR$(17);
  LastCurRow = Table.CurRow

END IF
 
' ------ Highlight the current array choice
COLOR BGColor, FGColor                  ' reverse colors for hi-light
LOCATE Table.CurRow, Table.LCol
Temp$ = Array$(Table.Choice)
Temp$ = Temp$ + SPACE$(Table.MaxLen - LEN(Temp$))
PRINT Temp$
LastCh = Table.Choice
LOCATE Table.CurRow, Table.LCol
COLOR FGColor, BGColor                  ' reset colors

RETURN

END SUB

SUB SelectDir (Wnd)
'***************************************************************************
'* SUB:         SelectDir
'*                Changes to the directory chosen by the user
'*
'* PARAMETERS:  Wnd     Active window number
'***************************************************************************

IF DirNames$(DirLst.Choice) = ".       " THEN    ' force change to parent
	 SHELL "cd .."
ELSE
	 DosCom$ = "cd " + DirNames$(DirLst.Choice)  ' change to new directory
	 SHELL DosCom$
END IF

CALL GetCurrPath
CALL InitDirs
CALL InitFiles
CALL GetDirNames(CurrDir$)
CALL GetFiles(CurrDir$)

Wnd = 2


END SUB

SUB SelectDrv (Wnd)
'**************************************************************************
'* SUB:         SelectDrv
'*                Changes to the selected drive
'*
'* PARAMETERS:  Wnd     Active window
'**************************************************************************

	SELECT CASE DrvLst.Choice
	  CASE 1
		LOCATE 7, 10
		COLOR 7, 4
		BEEP
		PRINT "Please insert Diskette in Drive A. ";
		PRINT "Press any key to continue..."
		COLOR FGColor, BGColor
		BEEP
		WHILE INKEY$ = "": WEND
		SHELL "a:"
	  CASE 2
		LOCATE 7, 10
		COLOR 7, 4
		BEEP
		PRINT "Please insert Diskette in Drive B. ";
		PRINT "Press any key to continue..."
		COLOR FGColor, BGColor
		BEEP
		WHILE INKEY$ = "": WEND
		SHELL "b:"
	  CASE 3
		SHELL "c:"
	  CASE 4
		SHELL "d:"
	  CASE 5
		SHELL "e:"
	END SELECT

	CALL GetCurrPath
	CALL GetDirNames(CurrDir$)
	CALL GetFiles(CurrDir$)
	CALL InitDirs
	CALL InitFiles
	CALL ScrollLst(DirNames$(), DirLst, 1, 2)
	CALL ScrollLst(FileNames$(), FileLst, 1, 3)
	Wnd = 2

END SUB

SUB SelectFile (FileName$)
'**************************************************************************
'* SUB          SelectFile
'*                  Reads SUB and FUNCTION names from the user selected
'*                  file into the appropriate arrays.
'*
'* PARAMETERS:  FileName$   Name of user selected file
'*
'* SHARED:      Subs$()
'*              Funcs$()
'**************************************************************************

REDIM Subs$(50), Funcs$(50)

OPEN FileName$ FOR INPUT AS #1
	 
i = 1                                   'counter for SUB array
j = 1                                   'counter for FUNCTION array

' -------- Assign MAIN as first name of SUB's array
Subs$(1) = "MAIN MODULE ONLY"
i = 2

' --------  Search for SUB and FUNCTION names.  These are assigned
'           to arrays and displayed on the screen.

DO UNTIL EOF(1)
  LINE INPUT #1, LineBuffer$

  FoundSub = INSTR(LineBuffer$, "DECLARE SUB")
  FoundFunc = INSTR(LineBuffer$, "DECLARE FUNCTION")

  IF FoundSub > 0 AND LEFT$(LineBuffer$, 7) = "DECLARE" THEN
	FOR k = 13 TO LEN(LineBuffer$)
	  Char$ = MID$(LineBuffer$, k, 1)
	  IF Char$ <> " " THEN
	SubName$ = SubName$ + Char$
	  ELSE
	EXIT FOR
	  END IF
	NEXT k
	Subs$(i) = SubName$
	i = i + 1
	SubName$ = ""
  END IF

  IF FoundFunc > 0 AND LEFT$(LineBuffer$, 7) = "DECLARE" THEN
	FOR k = 18 TO LEN(LineBuffer$)
	  Char$ = MID$(LineBuffer$, k, 1)
	  IF Char$ <> " " THEN
	FuncName$ = FuncName$ + Char$
	  ELSE
	EXIT FOR
	  END IF
	NEXT k
	Funcs$(j) = FuncName$
	j = j + 1
	FuncName$ = ""
  END IF

LOOP

CLOSE #1

END SUB