ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/BBS/RBBS_PC/SUBJCT30.ZIP/SUBJECT.BAS

BASIC Source File | 1990-10-10 | 23.9 KB | 851 lines

' --------------------------------------------------------
'
' Dedicated to the devotional service of Lord Shri Krishna
'
'             by Vaishnava dasa on 10/20/89
'                Release 3.0 on 10/10/90
'
'
' Version 1.0 (10/20/89)
' Version 1.1 (10/21/89)
' Version 1.2 (10/21/89)
' Version 1.3 (11/28/89)
' Version 1.4 (12/13/89)
' Version 1.4 (12/18/89)
' o Reads format file (default "SUBJECT.TMP" on default drive) for
'     customizing output file using "F:" optional command-line
'     parameter.  Recognizes these format strings:
'     1) TODATExx - date of latest message
'     2) FMDATExx - date of earliest message
'     3) MSG - number of messages in conference
'     4) AREA - name of conference given in command line.  SUBJECT.exe
'               will overwrite 16 characters following "AREA" string
'               when copying from the format file to the output file.
'               This is needed if you make a generic template format
'               file where AREA variables vary in length.  If you are
'               using one template per conference, you can omit this
'               AREA variable and just put the name of the conference
'               in the template file
'     5) SUBJECT8901234567890 - 20 characters for SUBJECT string
'     6) ### - 3 characters for number of messages in SUBJECT thread
'
'     When using new "F:" parameter, all the above format string
'     variables are optional.  Command line parameters "S:", "D:" and
'     "L:" are ignored.  Using the "F:" parameter assumes that you
'     will put in your own Smart-text commands.  Will even work with
'     format files using ansi commands (as done by THEDRAW) as long as
'     the above strings can be found in the format file
'
' Version 2.0 (12/25/89)
' Version 2.1 (5/31/90)
' o  Gets rid of G:, A:, B:, and F:C parameters.
' o  Compatible with RBBS-PC Version 17.3
' o  Strips "RE:" from Subjects
'
' Version 3.0 (10/10/90)
' o  Got rid of all internal format for Smart-text; this means
'    that (*.tmp) template files are absolutely required
' o  No more command-line parameters supported except ones
'    absolutely required (i.e. I:, O:, and C:)
' o  SUBJECT will only support making all three *W.DEF files,
'    namely, *W.DEF, *WG.DEF, and *WC.DEF.  I have no idea if
'    this will be backwardly compatible with RBBS-PC prior to
'    Version 17.3
' o  Now SUBJECT will support full 25 character SUBJECTs in output
'    This is not backwardly compatible with any previous release of
'    SUBJECT.EXE, or the previous default-sample *.TMP files
'    New sample *.TMP files will be included with this release
'
' --------------------------------------------------------
'
' SUBJECT Version 3.x - A RBBS-PC Conference messages utility
'
' Use:  Scans RBBS-PC messages files and writes a file listing
' ~~~   the most popular threads in descending order.  Formatting
'       options dependent solely on required *.TMP template files.
'
DEFINT A-Z
DECLARE SUB comline (n, a$(), max)
DECLARE SUB center (a$, pad, ret)
DECLARE SUB delayit (secs, display)
pad = 1
ret = 1
false = 0
true = NOT false
restrow = 1
restcol = 1
ON ERROR GOTO HANDLER

' DECLARE AN ARRAY TO GET COMMANDLINE PARAMETERS
DIM a$(1 TO 4)
CALL comline(n, a$(), 4)
IF n = 0 THEN GOTO showcommands
FOR showarray = 1 TO 4
  IF INSTR(a$(showarray), "I:") <> 0 THEN
    filename$ = MID$(a$(showarray), 3, 255)
  END IF
  IF INSTR(a$(showarray), "O:") <> 0 THEN
    outputfile$ = MID$(a$(showarray), 3, 255)
  END IF
  IF INSTR(a$(showarray), "C:") <> 0 THEN
    confname$ = MID$(a$(showarray), 3, 12)
  END IF
  IF INSTR(a$(showarray), "?") <> 0 THEN
    helptext = true
  END IF
NEXT showarray
ERASE a$

' IF REQUIRED PARAMETERS MISSING, GOTO SHOW HIM WHAT'S WRONG HERE
IF LEN(filename$) = 0 THEN GOTO showcommands
IF LEN(outputfile$) = 0 THEN GOTO showcommands
IF LEN(confname$) = 0 THEN GOTO showcommands
IF helptext THEN GOTO showcommands

' DEFINE RBBS-PC's MESSAGE HEADER RECORD
TYPE recordtype
  private AS STRING * 1
  numb1mess AS STRING * 4
  namemsgfrom AS STRING * 31
  namemsgto AS STRING * 22
  notused1 AS STRING * 9
  mmdate AS STRING * 2
  notused1a AS STRING * 1
  dddate AS STRING * 2
  notused1b AS STRING * 1
  yydate AS STRING * 2
  subject AS STRING * 25
  notused2 AS STRING * 15
  alive AS STRING * 1
  recnos AS STRING * 4
  notused3 AS STRING * 8
END TYPE

' DEFINE RBBS-PC's CHECKPOINT RECORD
TYPE checkrecord
  maximess AS STRING * 8
  not2used AS STRING * 59
  locatefirstmess AS STRING * 7
  noteverused1 AS STRING * 54
END TYPE

' DEFINE SUBJECT ARRAY
TYPE tosort
  titles AS STRING * 25
END TYPE

' DEFINE SUBJECT ARRAY WITH NUMBER OF COUNT
TYPE tosort2
  titles2 AS STRING * 25
  amount AS STRING * 3
END TYPE

DIM arecord AS recordtype
DIM firstrecord AS checkrecord

' FORMAT OUTPUT HEADER DISPLAY
CLS

a1$ = "SUBJECT Version 3.0 - A RBBS-PC Automatic Conference Welcome-file Maker"
a2$ = STRING$(LEN(a1$), CHR$(205))
a3$ = "Written by Vaishnava dasa - Krishna Yoga Foundation BBS"
a4$ = "FidoNet 1:115/800 - 312/743-6116"
a5$ = CHR$(34) + "Chant " + CHR$(96) + "Hare Krishna" + CHR$(39) + " and be happy" + CHR$(34)
a6$ = "Use SUBJECT 3.0 with RBBS-PC Version 17.3"
a7$ = "SUBJECT is also ideal with MSGTOSS:  The Fast RBBS-PC Mail-tosser!"
a$ = a1$
CALL center(a$, pad, ret)
a$ = a2$
CALL center(a$, pad, ret)
a$ = a3$
CALL center(a$, pad, ret)
a$ = a4$
CALL center(a$, pad, ret)
a$ = a5$
CALL center(a$, pad, ret)
PRINT
a$ = a6$
CALL center(a$, pad, ret)
a$ = a7$
CALL center(a$, pad, ret)
restrow = CSRLIN
restcol = POS(0)


' SET UP ARRAY FOR SCREEN SAVING
DIM SCR(2000)
DSEG = VARSEG(SCR(1))
DOFS = VARPTR(SCR(1))
page = 0
scrmode = -1
CALL DSCRSAVE(DSEG, DOFS, page, scrmode)
CLS

' OPEN THE INPUT FILE AND READ SUBJECTS
OPEN filename$ FOR RANDOM SHARED AS #1
GET #1, 1, firstrecord
xx1$ = firstrecord.maximess

' NUMBER OF LAST MESSAGE IN MESSAGE BASE
max.mess = VAL(xx1$)

' RECORD NUMBER OF FIRST MESSAGE IN MESSAGE BASE
xx2$ = firstrecord.locatefirstmess
first.recno = VAL(xx2$)

' READ FIRST MESSAGE HEADER RECORD GET NUMBER OF THIS MESSAGE
GET #1, first.recno, arecord
xx3$ = arecord.numb1mess
first.messno = VAL(xx3$)

' GET TOTAL NUMBER OF MESSAGES IN MESSAGE BASE POSSIBLE
maxi = max.mess - first.messno + 1

' DEFINE 2 ARRAYS SUITABLE TO FIT
DIM myarray(1 TO (maxi + 1)) AS tosort
DIM mysorted(1 TO (maxi + 1)) AS tosort2

' ASSIGN NUMBER OF FIRST MESSAGE HEADER RECORD NUMBER TO "Q"
q = first.recno

' Y -> THE NUMBER OF ACTUAL SUBJECTS IN THIS MESSAGE BASE
y = 0

olddate$ = "991231"
recentdate$ = "800101"

' GET THE FIRST MESSAGE HEADER RECORD
GET #1, q, arecord

' NEW DISPLAY PORT FOR WATCHING MESSAGES
COLOR 14, 1
LOCATE 1, 1
PRINT STRING$(2000, CHR$(240));
LOCATE 1, 1
ulr = 5: ulc = 24
lrr = 19: lrc = 56
CALL mwindow(ulr, ulc, lrr, lrc)
LOCATE ulr, ulc
fore = 15: back = 19
frame = 1: label$ = "Subject:"
shadow = 0
grow = 1

CALL WindowManager(ulr, ulc, lrr, lrc, frame, fore, back, grow, shadow, label, label$, page, scrmode)
' GOTO BOTTOM OF WINDOW
LOCATE lrr, ulc + 1

' LOOP AGAIN UNTIL EXIT; Y MUST BE LESS THAN CALCULATED MAXIMUM
COLOR 15, 11
DO WHILE y <= maxi

  ' IF MESSAGE IS PRIVATE, "(R)", OR BLANK, THEN DISREGARD
  IF arecord.private = "*" OR RTRIM$(arecord.subject) = "(R)" OR LEN(RTRIM$(LTRIM$(arecord.subject))) = 0 OR arecord.alive = CHR$(226) THEN

    ' UPDATE TO GET NEXT RECORD HEADER
    q = q + VAL(arecord.recnos)

    ' CHECK NEXT RECORD FOR BAD RECORD NUMBER INFO, IF SO, ABORT
    IF LEN(RTRIM$(LTRIM$(arecord.subject))) = 0 THEN
      ' ENCOUNTERED BLANK SUBJECT FIELD
      GET #1, q, arecord
      IF VAL(arecord.recnos) <= 0 OR VAL(arecord.recnos) > 9999 THEN
        y = y - 1
        EXIT DO
      END IF
    END IF
    IF VAL(arecord.numb1mess) = VAL(xx1$) THEN
      y = y - 1
      EXIT DO
    END IF
  ' MESSAGE IS OK, THEREFORE CONTINUE TO PROCESS
  ELSE

    ' CHECK FOR NULLS IN SUBJECT AND REPLACE WITH SPACES
    IF INSTR(arecord.subject, CHR$(0)) <> 0 THEN
      DO WHILE INSTR(arecord.subject, CHR$(0)) <> 0
        x = INSTR(arecord.subject, CHR$(0))
        arecord.subject = MID$(arecord.subject, 1, x - 1) + " " + MID$(arecord.subject, x + 1, 25)
      LOOP
    END IF

    ' CHECK FOR (R)s AND REMOVE IF FOUND
    DO
      IF LEFT$(arecord.subject, 3) = "(R)" THEN
        arecord.subject = MID$(arecord.subject, 4, 25)
      END IF
    LOOP WHILE LEFT$(arecord.subject, 3) = "(R)"

    ' CHECK FOR "RE:"s AND REMOVE IF FOUND
    DO
      IF LEFT$(arecord.subject, 3) = "RE:" THEN
        arecord.subject = MID$(arecord.subject, 4, 25)
      END IF
    LOOP WHILE LEFT$(arecord.subject, 3) = "RE:"

    ' BEGIN ARRAY NUMBERS WITH "1"
    IF y = 0 THEN y = 1

    ' STORE NUMBER "y" AND SUBJECT TO ARRAY
    myarray(y).titles = arecord.subject

    ' GET NEXT MESSAGE HEADER RECORD NUMBER
    q = q + VAL(arecord.recnos)

    ' GET MESSAGE DATE OF THIS MESSAGE IN YYMMDD FORMAT
    messdate$ = arecord.yydate + arecord.mmdate + arecord.dddate

    ' CHECK TO SEE VALIDITY OF THIS DATE (NO ZEROS)
    IF VAL(arecord.yydate) <> 0 AND VAL(arecord.mmdate) <> 0 AND VAL(arecord.dddate) <> 0 THEN

      ' COMPARE AGAINST OLDEST MESSAGE DATE AND REPLACE VALUE IF OLDER
      IF LEFT$(messdate$, 1) <> " " AND messdate$ < olddate$ THEN
        olddate$ = messdate$
      END IF

      ' COMPARE AGAINST MOST RECENT DATE MESSAGE AND UPDATE IF NEED BE
      IF messdate$ > recentdate$ THEN recentdate$ = messdate$
    END IF

    ' FOR DISPLAY, SHOW SUBJECTS
    PRINT RIGHT$("  " + STR$(y), 3) + " - " + LEFT$(arecord.subject, 1) + MID$(LCASE$(arecord.subject), 2)
    CALL scroll(ulr, ulc, lrr, lrc, 1)
    LOCATE lrr, ulc + 1

    ' IF FIRST MESSAGE IS LAST MESSAGE THEN EXIT DO
    IF VAL(arecord.numb1mess) = VAL(xx1$) THEN EXIT DO

    ' INCREMENT Y VARIABLE FOR COUNTING
    y = y + 1

    ' IF Y IS LARGER THAN ARRAY SIZE THEN LOWER BY 1 AND GET OUT
    IF y > maxi THEN
      y = y - 1
      EXIT DO
    END IF
  END IF
  GET #1, q, arecord
LOOP

IF y < 0 THEN y = 0

' FORMAT DATES WITH DASHES
olddate$ = MID$(olddate$, 3, 2) + "-" + RIGHT$(olddate$, 2) + "-" + LEFT$(olddate$, 2)
recentdate$ = MID$(recentdate$, 3, 2) + "-" + RIGHT$(recentdate$, 2) + "-" + LEFT$(recentdate$, 2)

' CLOSE THIS FILE AND SORT THE ARRAY
CLOSE #1

' FOR DISPLAY, SHOW END OF SCAN
FOR x = 1 TO 14
  PRINT
  CALL scroll(ulr, ulc, lrr, lrc, 1)
  LOCATE lrr, ulc + 1
NEXT x
PRINT RIGHT$("  " + STR$(y), 3) + " - Messages total"
CALL scroll(ulr, ulc, lrr, lrc, 1)
FOR x = 1 TO 13
  PRINT
  CALL scroll(ulr, ulc, lrr, lrc, 1)
  LOCATE lrr, ulc + 1
NEXT x

'RESTORE TO DIFFERENT COLOR
COLOR 15, 4
LOCATE 2, 1
a$ = SPACE$(LEN(a$))
CALL center(a$, pad, ret)

a$ = "Sorting..."
LOCATE 2, 1
CALL center(a$, pad, ret)

  offset = y \ 2
  DO WHILE offset > 0
    Limit = y - offset
    DO
      switch = false
      FOR counting = 1 TO Limit
        IF myarray(counting).titles > myarray(counting + offset).titles THEN
           SWAP myarray(counting), myarray(counting + offset)
           switch = counting
        END IF
      NEXT counting
      Limit = switch - offset
    LOOP WHILE switch
    offset = offset \ 2
  LOOP

' TAKE THE ARRAY AND FILL SECOND ARRAY (MYSORTED) WITH SUBJECT AND AMOUNTS
f = 1
FOR doit = 1 TO y
  x = 1
  mysorted(f).titles2 = myarray(doit).titles
  FOR newdoit = (doit + 1) TO y + 1
  IF myarray(newdoit).titles = myarray(doit).titles THEN
    x = x + 1
  ELSE
    mysorted(f).amount = RIGHT$(("  " + LTRIM$(STR$(x))), 3)
    doit = newdoit - 1
    newdoit = y + 1
  END IF
  NEXT newdoit
f = f + 1
NEXT doit

ERASE myarray

' SORTING MYSORTED ARRAY BY TOTALS
f = f - 1
LOCATE 2, 1
a$ = SPACE$(LEN(a$))
CALL center(a$, pad, ret)
a$ = "Totaling..."
LOCATE 2, 1
CALL center(a$, pad, ret)


offset = f \ 2
DO WHILE offset > 0
  Limit = f - offset
  DO
    switch = false
    FOR counting = 1 TO Limit
      IF mysorted(counting).amount < mysorted(counting + offset).amount THEN
        SWAP mysorted(counting), mysorted(counting + offset)
        switch = counting
      ELSE
        IF mysorted(counting).amount = mysorted(counting + offset).amount THEN
          IF mysorted(counting).titles2 > mysorted(counting + offset).titles2 THEN
            SWAP mysorted(counting), mysorted(counting + offset)
            switch = counting
          END IF
        END IF
      END IF
    NEXT counting
    Limit = switch - offset
  LOOP WHILE switch
  offset = offset \ 2
LOOP

' REGULAR NON-GRAPHICS, NON-COLOR OUTPUT FILE
USERFORMAT:

' ASSIGN INPUTFILE NAME TO NAME$
name$ = filename$

' PARSE NAME$ TO GET PATH AND NAME OF INPUT FILE
DO WHILE INSTR(name$, "\") <> 0
  c = INSTR(filename$, "\")
  name$ = MID$(name$, c + 1, 255)
  D = c + D
  path$ = LEFT$(filename$, D)
LOOP

' CHECK FOR 'M.DEF' EXTENSION OF NAME$
IF INSTR(name$, "M.DEF") <> 0 THEN name$ = LEFT$(name$, INSTR(name$, "M.DEF") - 1)

' TEST TO SEE WHAT FILE TO USE AS A TEMPLATE
IF INSTR(name$, ".") = 0 THEN

  ' THE INPUT FILENAME HAS NO EXTENSION...
  OPEN name$ + ".TMP" FOR APPEND SHARED AS #1

  ' CHECK TO SEE IF THERE IS A TEMPLATE FILE IN THE DEFAULT DIRECTORY FOR THIS
  IF LOF(1) = 0 THEN
    CLOSE #1
    KILL name$ + ".TMP"
    OPEN "subject.tmp" FOR INPUT SHARED AS #1
    templefile$ = "SUBJECT.TMP"
  ELSE
    IF LOF(1) > 0 THEN
      CLOSE #1
      OPEN name$ + ".TMP" FOR INPUT SHARED AS #1
      templefile$ = name$ + ".TMP"
    END IF
  END IF
ELSE

  ' NO EXTENSION ON THIS FILE...USE DEFAULT SUBJECT.TMP FILE
  OPEN "subject.tmp" FOR INPUT SHARED AS #1
  templefile$ = "SUBJECT.TMP"
END IF
c = 0
D = 0

' OUTPUT FILE PROCESSING
outname$ = outputfile$
DO WHILE INSTR(outname$, "\") <> 0
  c = INSTR(outputfile$, "\")
  outname$ = MID$(outname$, c + 1, 255)
  D = c + D
  path$ = LEFT$(outputfile$, D)
LOOP

' PARSE OUTPUT FILENAME TO GET MESSAGE BASE NAME WITHOUT W.DEF
IF INSTR(outname$, "W.DEF") <> 0 THEN
  outname$ = LEFT$(outname$, INSTR(outname$, "W.DEF") - 1)
END IF

' IF NAME IS TOO LONG SET VARIABLE TO TRUE
IF LEN(outname$) >= 7 THEN nametoolong = -1

' OPEN THE FILE FOR NON-GRAPHICS, NON-COLOR OUTPUT FILE, REGULAR *W.DEF FILE
OPEN outputfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputfile$
IF LEN(confname$) >= 20 THEN confname$ = LEFT$(confname$, 20)
IF LEN(confname$) < 20 THEN confname$ = LEFT$(confname$ + SPACE$(20), 20)

' IF NO MESSAGES, MAKE SURE DATES ARE RESET PROPERLY
IF y = 0 THEN
  recentdate$ = "00-00-00"
  olddate$ = "00-00-00"
END IF

' FORMAT 'MSG' OUTPUT OR, NUMBER OF MESSAGES IN MESSAGE BASE TO 3 CHARACTERS
IF y > 0 THEN
  IF y >= 1 AND y < 10 THEN
    messages$ = "  " + LTRIM$(STR$(y))
  ELSE
    IF y >= 10 AND y < 100 THEN
      messages$ = " " + LTRIM$(STR$(y))
    ELSE
      IF y >= 100 AND y < 1000 THEN
        messages$ = LTRIM$(STR$(y))
      END IF
    END IF
  END IF
END IF
IF y = 0 THEN messages$ = "  0"

' THIS ROUTINE READS TEMPLATE FILE AND REPLACES ALL VARIABLES WITH REAL INFO
' THEN CLOSES THE FILE
userformat2:
a = 0
b = 0
DO WHILE NOT EOF(1)
  LINE INPUT #1, x$
  IF INSTR(x$, "TODATExx") <> 0 THEN
    z = INSTR(x$, "TODATExx")
    x$ = MID$(x$, 1, (z - 1)) + recentdate$ + MID$(x$, z + 8, 255)
  END IF
  IF INSTR(x$, "FMDATExx") <> 0 THEN
    z = INSTR(x$, "FMDATExx")
    x$ = MID$(x$, 1, (z - 1)) + olddate$ + MID$(x$, z + 8, 255)
  END IF
  IF INSTR(x$, "MSG") <> 0 THEN
    z = INSTR(x$, "MSG")
    x$ = MID$(x$, 1, (z - 1)) + messages$ + MID$(x$, z + 3, 255)
  END IF
  IF INSTR(x$, "AREA") <> 0 THEN
    z = INSTR(x$, "AREA")
    x$ = MID$(x$, 1, (z - 1)) + RTRIM$(confname$) + MID$(x$, z + LEN(RTRIM$(confname$)), 255)
  END IF
  DO WHILE INSTR(x$, "###") <> 0 OR INSTR(x$, "SUBJECT890123456789012345") <> 0
    IF INSTR(x$, "###") <> 0 THEN
      z = INSTR(x$, "###")
      IF INSTR(mysorted(a + 1).amount, CHR$(0)) = 0 THEN
        x$ = MID$(x$, 1, (z - 1)) + mysorted(a + 1).amount + MID$(x$, z + 3, 255)
        IF f >= a THEN a = a + 1
      ELSE
        x$ = MID$(x$, 1, (z - 1)) + "   " + MID$(x$, z + 3, 255)
        IF f >= a THEN a = a + 1
      END IF
    END IF
    IF INSTR(x$, "SUBJECT890123456789012345") <> 0 THEN
      z = INSTR(x$, "SUBJECT890123456789012345")
      IF INSTR(mysorted(b + 1).titles2, CHR$(0)) = 0 THEN
        x$ = MID$(x$, 1, (z - 1)) + mysorted(b + 1).titles2 + MID$(x$, z + 25, 255)
        IF f >= b THEN b = b + 1
      ELSE
        x$ = MID$(x$, 1, (z - 1)) + SPACE$(25) + MID$(x$, z + 25, 255)
        IF f >= b THEN b = b + 1
      END IF
    END IF
  LOOP
  PRINT #2, x$
LOOP
CLOSE
IF NOT asciido THEN
  a$ = "Now on disk: "
  count = 1
END IF
IF LEN(outfile$) > 21 THEN
  IF count = 1 THEN outfile$ = "non-graphics"
  IF count = 2 THEN outfile$ = "graphics"
  IF count = 3 THEN outfile$ = "color-graphics"
END IF
a$ = a$ + LCASE$(outfile$)
LOCATE 2, 1
CALL center(a$, pad, ret)
count = count + 1

a$ = RTRIM$(a$)

IF asciido = false GOTO ASCIIMARK
IF colordo = false GOTO COLORMARK
LOCATE 23, 1
CALL delayit(3, false)
GOTO finish

ASCIIMARK:
asciido = true

' IF INPUTFILE NAME TOO LONG CAN'T MAKE GRAPHICS OR COLOR FILE
IF nametoolong THEN
  GOTO finish
END IF

' CONTINUE TO PROCESS, UPDATE OUTPUT STRING FOR SCREEN DISPLAY
a$ = a$ + ", "

' CHECK FOR SPECIAL *G.TMP FILE
OPEN name$ + "G.TMP" FOR APPEND SHARED AS #1
IF LOF(1) = 0 THEN
  CLOSE #1
  KILL name$ + "G.TMP"
  OPEN "subjectg.tmp" FOR INPUT SHARED AS #1
  templefile$ = "SUBJECTG.TMP"
ELSE
  CLOSE #1
  OPEN name$ + "G.TMP" FOR INPUT SHARED AS #1
  templefile$ = name$ + "G.TMP"
END IF
c = 0
D = 0
nameout$ = outputfile$
path$ = ""
DO WHILE INSTR(nameout$, "\") <> 0
  c = INSTR(outputfile$, "\")
  nameout$ = MID$(nameout$, c + 1, 255)
  D = c + D
  path$ = LEFT$(outputfile$, D)
LOOP
IF INSTR(nameout$, "W.DEF") <> 0 THEN
   nameout$ = LEFT$(nameout$, INSTR(nameout$, "W.DEF") - 1)
END IF
outputgfile$ = path$ + nameout$ + "WG.DEF"
OPEN outputgfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputgfile$
GOTO userformat2

COLORMARK:
colordo = true

' CONTINUE TO PROCESS, UPDATE OUTPUT STRING FOR SCREEN DISPLAY
a$ = a$ + ", "

OPEN name$ + "C.TMP" FOR APPEND SHARED AS #1
IF LOF(1) = 0 THEN
  CLOSE #1
  KILL name$ + "C.TMP"
  OPEN "subjectc.tmp" FOR INPUT SHARED AS #1
  templefile$ = "SUBJECTC.TMP"
ELSE
  CLOSE #1
  OPEN name$ + "C.TMP" FOR INPUT SHARED AS #1
  templefile$ = name$ + "C.TMP"
END IF
c = 0
D = 0
nameout$ = outputfile$
path$ = ""
DO WHILE INSTR(nameout$, "\") <> 0
  c = INSTR(outputfile$, "\")
  nameout$ = MID$(nameout$, c + 1, 255)
  D = c + D
  path$ = LEFT$(outputfile$, D)
LOOP
IF INSTR(nameout$, "W.DEF") <> 0 THEN
   nameout$ = LEFT$(nameout$, INSTR(nameout$, "W.DEF") - 1)
END IF
outputcfile$ = path$ + nameout$ + "WC.DEF"
OPEN outputcfile$ FOR OUTPUT SHARED AS #2
outfile$ = outputcfile$
GOTO userformat2

finish:
CLOSE
IF nametoolong THEN
  COLOR 0, 7
  LOCATE 2, 1
  a$ = "Conference name too long to make Graphics or Color Welcome files"
  CALL center(a$, pad, ret)
  PRINT
  LOCATE 22, 1
  CALL delayit(20, true)
END IF
GOTO theend

showcommands:
CLS
a$ = "Required format for SUBJECT.EXE (Version 3.0):"
CALL center(a$, pad, ret)
a$ = "══════════════════════════════════════════════"
CALL center(a$, pad, ret)
a$ = "SUBJECT I:file O:file C:name (? = Help)"
CALL center(a$, pad, ret)
PRINT
a$ = "Template (SUBJECT?.TMP) files must be on the default drive/directory"
CALL center(a$, pad, ret)
a$ = "For complete compatibility, use 6 characters or less for your RBBS-PC"
CALL center(a$, pad, ret)
a$ = "Messages files (e.g. 'optionM.DEF')"
CALL center(a$, pad, ret)
PRINT
a$ = "Examples:"
CALL center(a$, pad, ret)
a$ = "SUBJECT i:c:\rbbs\rbbspcM.DEF o:c:\rbbs\rbbspcW.DEF c:rbbs-pc "
CALL center(a$, pad, ret)
a$ = "SUBJECT i:binkM.DEF o:binkW.DEF c:binkleyterm "
CALL center(a$, pad, ret)
PRINT
a$ = "Required command-line parameters:"
CALL center(a$, pad, ret)
a$ = "i: - Name of Input RBBS-PC Messages file to read"
CALL center(a$, pad, ret)
a$ = "o: - Name of Output file to create"
CALL center(a$, pad, ret)
a$ = "c: - Name of Conference--Do NOT use any [SPACE] characters"
CALL center(a$, pad, ret)
IF NOT helptext THEN
  IF LEN(COMMAND$) > 0 THEN
    PRINT
    a$ = "Correct the current command-line:"
    CALL center(a$, pad, ret)
    a$ = "SUBJECT " + COMMAND$
    CALL center(a$, pad, ret)
  END IF
ELSE
  PRINT
  a$ = "Options:"
  CALL center(a$, pad, ret)
  a$ = "SUBJECT also looks for special *.TMP files so that you can customize"
  CALL center(a$, pad, ret)
  a$ = "Welcome files for your conferences.  Rather than using the default "
  CALL center(a$, pad, ret)
  a$ = "SUBJECT?.TMP files, you can create your own for any particular conference"
  CALL center(a$, pad, ret)
  a$ = "and SUBJECT will look for that one first, and use it, if it matches the"
  CALL center(a$, pad, ret)
  a$ = "name of the message file (e.g. 'other.TMP,' 'otherG.TMP,' or 'otherC.TMP'"
  CALL center(a$, pad, ret)
  a$ = "for the Conference 'otherM.DEF.'  Read documentation for more details."
  CALL center(a$, pad, ret)
END IF
PRINT
CALL delayit(120, true)
GOTO theend

HANDLER:
listen$ = "t180 o1 p2 p8 l8 ggg l1 e-"
fate$ = "t140 p24 p8 l8 fff t110 l1 d P2"
PLAY listen$ + fate$
number = ERR
IF number = 63 THEN
  CLOSE #1
  KILL filename$
  OPEN "subject.err" FOR APPEND SHARED AS #2
  LOCATE 11, 1
  PRINT SPACE$(80 * 3);
  LOCATE 12, 1
  COLOR 0, 7, 0
  a$ = "Basic Error 63:  Specified RBBS-PC Messages file NOT FOUND!"
  CALL center(a$, pad, 0)
  COLOR 7, 0, 0
  PRINT #2, "An error has occured running SUBJECT.EXE at:"
  PRINT #2, "  Date:  "; DATE$; ";  Time:  "; TIME$
  PRINT #2, "  Processing Messages file: "; filename$
  PRINT #2, "  Check if the Message file exists in the proper directory."
  PRINT #2, "---"
  PRINT
  LOCATE 23
  CALL delayit(30, true)
  ON ERROR GOTO theend
ELSE
  CLOSE
  LOCATE 11, 1
  PRINT SPACE$(80 * 4);
  LOCATE 12, 1
  COLOR 0, 7, 0
  a$ = "SUBJECT encountered untrapped error number " + LTRIM$(STR$(number))
  CALL center(a$, pad, 1)
  COLOR 7, 0, 0
  COLOR 0, 7, 0
  a$ = "Refer to your BASIC manual for more information about this Error code"
  CALL center(a$, pad, 1)
  COLOR 7, 0, 0
  OPEN "subject.err" FOR APPEND SHARED AS #2
  PRINT #2, "An error has occured running SUBJECT.EXE at:"
  PRINT #2, "  Date:  "; DATE$; ";  Time:  "; TIME$
  PRINT #2, "  Processing Messages file: "; filename$
  PRINT #2, "  SUBJECT.EXE encountered untrapped error number"; number
  PRINT #2, "  Read your BASIC manual for more information about this Error code."
  PRINT #2, "---"
  LOCATE 23
  CALL delayit(30, true)
  ON ERROR GOTO theend
END IF

theend:
' FOR RESTORING, USE THIS
page = 0
scrmode = -1
DSEG = VARSEG(SCR(1))
DOFS = VARPTR(SCR(1))
CALL DSCRREST(DSEG, DOFS, page, scrmode)
LOCATE restrow, restcol
END

SUB center (a$, pad, ret)
  a$ = SPACE$(pad) + RTRIM$(LTRIM$(a$)) + SPACE$(pad)
  col! = ((80 - LEN(a$)) / 2)
  IF INSTR(STR$(col!), ".5") <> 0 THEN col! = col! - .5
  LOCATE , col! + 1
  PRINT a$;
  IF ret <> 0 THEN PRINT
END SUB

SUB comline (NumArgs, Args$(), MaxArgs) STATIC
CONST false = 0, true = NOT false
NumArgs = 0
in = false
c1$ = COMMAND$
L = LEN(c1$)
FOR I = 1 TO L
  c$ = MID$(c1$, I, 1)
  IF (c$ <> " " AND c$ <> CHR$(9)) THEN
    IF NOT in THEN
      IF NumArgs = MaxArgs THEN EXIT FOR
      NumArgs = NumArgs + 1
      in = true
    END IF
    Args$(NumArgs) = Args$(NumArgs) + c$
  ELSE
    in = false
  END IF
NEXT I
END SUB

SUB delayit (secs, display)
  COLOR 15, 4
  start! = TIMER
  DO WHILE INKEY$ = ""
    LOCATE , 1
    finish! = TIMER
    IF display THEN
      a$ = "Wait " + LTRIM$(STR$(INT(secs - (finish! - start!)))) + " seconds or press any key to continue..."
      CALL center(a$, 1, 0)
    END IF
    IF finish! - start! > secs THEN
      EXIT DO
    END IF
    FOR x = 1 TO 500
      IF INKEY$ <> "" THEN
        EXIT DO
      END IF
    NEXT x
  LOOP
END SUB