Category : BASIC Source Code
Archive   : QBLISTER.ZIP
Filename : QBLISTER.BAS

 
Output of file : QBLISTER.BAS contained in archive : QBLISTER.ZIP

'****************************************************************************
'* 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
'* [email protected] or [email protected]
'****************************************************************************
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$, "") 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