'===========================================================================
' Subject: THE ABC LISTER                    Date: 03-24-00 (23:56)       
' Author:  Sander Koning                     Code: QB, PDS                
' Origin:  san@koningddt.demon.nl          Packet: ABC.ABC
'===========================================================================
' -------------------------------------------------------------------
' | The ABC Lister                                 by Sander Koning |
' | --------------------------------------------------------------- |
' |                                                                 |
' | This program creates a .LST file from an .ABC + .IDX packet     |
' | (useful if you want to test the programs or make a list for any |
' | other purpose) in the same directory as where your .ABC and     |
' | .IDX files are.                                                 |
' |                                                                 |
' | Requirements: a Basic dialect which has a DIR$ function         |
' | (this program is written in PDS)                                |
' |                                                                 |
' |                                                                 |
' | Put the path where your .ABC + .IDX files are in the            |
' |  CONST PacketsDir = "..."                                       |
' |                                                                 |
' |                                                                 |
' | Output in .LST file is unsorted and full uppercase. Using my    |
' | text editor (Boxer) to sort & switch case is much easier for me |
' | than to add functions for this. Should you add such a function  |
' | to the program, please send me the changed version!             |
' |                                                                 |
' |                                                                 |
' | I am not responsible for any harm done to your computer or to   |
' | yourself by using this program.                      2000/03/16 |
' -------------------------------------------------------------------

DEFINT A-Z                                    ' Only use integers

DECLARE SUB GetIndex (Counter)                ' Sub declaration

CONST PacketsDir = "F:\QB\ABCREAD\1995"       ' Packets directory

CONST IDX = 1, ABC = 2, LST = 3               ' Make file handling easier

DIM SHARED ProgStart AS LONG                  ' First byte of program in .ABC

ON ERROR GOTO OOPS                            ' Error handling

CLS                                           ' Clear screen

Fil$ = DIR$(PacketsDir + "\*.ABC")            ' Get first ABC file
IF Fil$ = "" THEN ERROR 255                   ' If file is "", then there is
                                              ' no ABC file in this directory

NumFiles = NumFiles + 1                       ' Add one file to counter
REDIM PRESERVE SHARED File$(NumFiles)         ' Redimension array
File$(NumFiles) = LEFT$(Fil$, INSTR(Fil$, ".") - 1) ' Add file to array

WHILE Fil$ <> ""                              ' Get all files
  Fil$ = DIR$
  IF Fil$ <> "" THEN                          ' If DIR$ returned a file
    NumFiles = NumFiles + 1                   ' then add file to counter
    REDIM PRESERVE SHARED File$(NumFiles)     ' etc.
    File$(NumFiles) = LEFT$(Fil$, INSTR(Fil$, ".") - 1)
  END IF
WEND

FOR Counter = 1 TO UBOUND(File$)              ' Sorting routine
  FOR Count2 = Counter + 1 TO UBOUND(File$)
    IF File$(Counter) > File$(Count2) THEN    ' Sort files from A to Z
      SWAP File$(Counter), File$(Count2)
    END IF
  NEXT Count2
NEXT Counter
                                              ' Show keys
LOCATE 25, 1: PRINT " = next file    = previous file   Enter = make list   Esc = quit"

Counter = 1                                   ' Current packet counter

DO
  LOCATE 13, 37
  PRINT USING "\      \"; File$(Counter)      ' Print file and add spaces so
                                              ' no rubbish is displayed

  a$ = ""
  WHILE a$ = ""                               ' Wait for key
    a$ = INKEY$
  WEND

  SELECT CASE a$                              ' Which key is pressed?
    CASE CHR$(0) + CHR$(72)                   ' Up
      Counter = Counter + 1                   '   Increase counter
    CASE CHR$(0) + CHR$(80)                   ' Down
      Counter = Counter - 1                   '   Decrease counter
    CASE CHR$(13)                             ' Enter
      GetIndex Counter                        '   Get index
    CASE CHR$(27)                             ' Escape
      CLS                                     '   Clear screen
      END                                     '   Quit
  END SELECT

  IF Counter < 1 THEN Counter = UBOUND(File$) ' If counter = 0 then -> end
  IF Counter > UBOUND(File$) THEN Counter = 1 ' If counter > end then -> first
LOOP

OOPS:                                         ' Error handling routine
  COLOR 4                                     ' Red text
  CLS
  SELECT CASE ERR                             ' Which error
    CASE 255                                  ' 255 = custom error
      PRINT "Directory does not contain any ABC files"
    CASE ELSE                                 ' Else: QB error
      PRINT "Error"; ERR; "occured"
  END SELECT

END                                           ' And end

                                          ' Use only integers
'
SUB GetIndex (Counter)

  LOCATE 20, 1: PRINT "Please wait..."    ' Display a message

                                          ' Open the three files
  OPEN PacketsDir + "\" + File$(Counter) + ".IDX" FOR BINARY AS IDX
  OPEN PacketsDir + "\" + File$(Counter) + ".ABC" FOR BINARY AS ABC
  OPEN PacketsDir + "\" + File$(Counter) + ".LST" FOR OUTPUT AS LST

  DO
    Flag = 0                              ' Reset flag

    IDXLine$ = STRING$(78, 32)            ' Reset line
    GET IDX, , IDXLine$                   ' Get a line

    FOR a = 1 TO 78                       ' Any character > space in the line
                                          ' then line = ok
      IF ASC(MID$(IDXLine$, a, 1)) > 32 THEN Flag = 1
    NEXT a
    IF Flag = 0 THEN EXIT DO              ' Line not ok, then stop

    ProgStart = VAL(MID$(IDXLine$, 2, 8)) ' Get program starting byte
    ProgName$ = RTRIM$(MID$(IDXLine$, 17, 31)) ' Get full program name

    BasName$ = ""                         ' Reset .BAS file name

    SEEK ABC, ProgStart + 153             ' Go to .BAS file byte position
    DO                                    ' Get .BAS file name
      Char$ = " "
      GET ABC, , Char$                    ' Get character
      IF Char$ = " " THEN                 ' Space
        IF Space = 1 THEN                 '   If flag set then stop
          EXIT DO
        ELSE                              '   Else add to file name
          BasName$ = BasName$ + Char$     '   (looks strange but works ok!)
          Space = 1
        END IF
      ELSE                                ' Else
        BasName$ = BasName$ + Char$       '   Add to file name
      END IF
    LOOP
                                          ' Trim .BAS file name
    BasName$ = RTRIM$(MID$(BasName$, 1, 12))
                                          ' Output .BAS file name and program
                                          ' name to the .LST file
    PRINT #LST, BasName$; TAB(16); ProgName$
  LOOP

  CLOSE LST                               ' Close files
  CLOSE ABC
  CLOSE IDX

  LOCATE 20, 1: PRINT "              "    ' Erase wait message

END SUB