home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1995 November / PCWK1195.iso / inne / podstawy / dos / 4dos / 4uzytki / 4menu11w.exe / 4MENU.BAS next >
BASIC Source File  |  1991-03-08  |  5KB  |  186 lines
  1. ' Copyright 1991 by Jeffery G. Smith
  2. ' All rights reserved.
  3. '
  4. ' The files which make up this program release may be distributed freely
  5. ' only if they are unaltered and together in a copy of the original
  6. ' compressed file.
  7. '
  8. ' No fees may be charged for distribution without consent of the author
  9. ' except to cover the cost of materials.
  10. '
  11. ' This program is provided as is and the author assumes no responsibility
  12. ' for its performance.
  13.  
  14. REM $DYNAMIC
  15. OPTION BASE 1
  16.  
  17. TYPE ENTRY
  18.     choice AS STRING * 80
  19.     action AS STRING * 80
  20.     inkkey AS STRING * 4
  21. END TYPE
  22.  
  23. DECLARE FUNCTION countentries% (file AS STRING)
  24. DECLARE FUNCTION getline$ ()
  25. DECLARE SUB getentry (thing AS ENTRY)
  26. DECLARE SUB getname (m AS STRING, b AS STRING)
  27.  
  28. CONST FALSE% = 0, TRUE% = -1
  29. CONST SCRNHGT% = 25, SCRNWID% = 80, MAXENTRIES% = 19, T% = 4
  30. CONST NULFILE$ = "nul.mnu", LABEL$ = "menulabel", VAR$ = "%menuevar"
  31.  
  32. ON ERROR GOTO errhandle
  33.  
  34. COLOR 14, 0, 0
  35. PRINT "4Menu Version 1.0"
  36. PRINT "Copyright 1991 by Jeffery G. Smith"
  37. PRINT "All rights reserved"
  38.  
  39. mnunm$ = COMMAND$
  40. CALL getname(mnunm$, btmnm$)
  41. filefound% = TRUE%
  42. OPEN mnunm$ FOR INPUT AS #1
  43. CLOSE #1
  44.  
  45. DO UNTIL filefound% OR mnunm$ = NULFILE$
  46.     INPUT "Input file-name[.mnu] or NUL to exit: ", mnunm$
  47.     CALL getname(mnunm$, btmnm$)
  48.     filefound% = TRUE%
  49.     OPEN mnunm$ FOR INPUT AS #1
  50.     CLOSE #1
  51. LOOP
  52.  
  53. IF mnunm$ <> NULFILE$ THEN
  54.     entries% = countentries%(mnunm$)
  55.     IF entries% > MAXENTRIES% THEN ERROR 100
  56.     DIM menu(entries%) AS ENTRY
  57.     OPEN mnunm$ FOR INPUT AS #1
  58.     scrnfg$ = getline$
  59.     scrnbg$ = getline$
  60.     menufg$ = getline$
  61.     menubg$ = getline$
  62.     brdrfg$ = getline$
  63.     brdrbg$ = getline$
  64.     style$ = getline$
  65.     IF LEN(style$) > 1 OR VAL(style$) < 0 OR VAL(style$) > 4 THEN ERROR 105
  66.     title$ = getline$
  67.  
  68.     max% = LEN(title$)
  69.     FOR i% = 1 TO entries%
  70.         CALL getentry(menu(i%))
  71.         max$ = RTRIM$(menu(i%).choice$)
  72.         IF LEN(max$) > max% THEN max% = LEN(max$)
  73.         FOR j% = 1 TO i% - 1
  74.             IF RTRIM$(menu(i%).inkkey$) = RTRIM$(menu(j%).inkkey$) THEN ERROR 101
  75.         NEXT j%
  76.     NEXT i%
  77.  
  78.     row% = (SCRNHGT% - entries%) / 2
  79.     col% = (SCRNWID% - max%) / 2
  80.     tcol% = col% + ((max% - LEN(title$)) / 2)
  81.    
  82.     OPEN btmnm$ FOR OUTPUT AS #2
  83.     PRINT #2, ":"; LABEL$
  84.     PRINT #2, TAB(T%); "cls "; scrnfg$; " on "; scrnbg$
  85.     PRINT #2, TAB(T%); "drawbox"; row% - 4; col% - 2; row% + entries% + 1; col% + max% + 1; style$; SPC(1); brdrfg$; " on "; brdrbg$; " fill "; menubg$
  86.    
  87.     PRINT #2, TAB(T%); "scrput"; row% - 2; tcol%; menufg$; " on "; menubg$; SPC(1); title$
  88.     PRINT #2, TAB(T%); "scrput"; row% - 1; col%; menufg$; " on "; menubg$; SPC(1); STRING$(max%, 196)
  89.     FOR i% = row% TO entries% + row% - 1
  90.         PRINT #2, TAB(T%); "scrput"; i%; col%; menufg$; " on "; menubg$; SPC(1); RTRIM$(menu(i% - row% + 1).choice$)
  91.     NEXT i%
  92.  
  93.     PRINT #2, TAB(T%); "screen"; i%; col%
  94.     PRINT #2, TAB(T%); "inkey %"; VAR$
  95.    
  96.     PRINT #2,
  97.     PRINT #2, TAB(T%); "iff "; CHR$(34); VAR$; CHR$(34); " == "; CHR$(34); RTRIM$(menu(1).inkkey$); CHR$(34); " then"
  98.     PRINT #2, TAB(2 * T%); SPC(1); RTRIM$(menu(1).action$)
  99.     FOR i% = 2 TO entries%
  100.         PRINT #2, TAB(T%); "elseiff "; CHR$(34); VAR$; CHR$(34); " == "; CHR$(34); RTRIM$(menu(i%).inkkey$); CHR$(34); " then"
  101.         PRINT #2, TAB(2 * T%); SPC(1); RTRIM$(menu(i%).action$)
  102.     NEXT i%
  103.     PRINT #2, TAB(T%); "else"
  104.     PRINT #2, TAB(2 * T%); "beep 200 4"
  105.     PRINT #2, TAB(2 * T%); "goto "; LABEL$
  106.     PRINT #2, TAB(T%); "endiff"
  107.    
  108.     CLOSE #2
  109. END IF
  110.  
  111. END
  112.  
  113. errhandle:
  114.     IF ERR = 53 THEN
  115.         filefound% = FALSE%
  116.     ELSEIF ERR = 100 THEN
  117.         PRINT : PRINT "Menu has too many entries."
  118.         STOP
  119.     ELSEIF ERR = 101 THEN
  120.         PRINT : PRINT "Key field has too many characters."
  121.         STOP
  122.     ELSEIF ERR = 102 THEN
  123.         PRINT : PRINT "Incorrect number of lines for proper format"
  124.         STOP
  125.     ELSEIF ERR = 103 THEN
  126.         PRINT : PRINT "Same key used for two actions."
  127.         STOP
  128.     ELSEIF ERR = 104 THEN
  129.         PRINT : PRINT "usage: 4menu [description-file]"
  130.         STOP
  131.     ELSEIF ERR = 105 THEN
  132.         PRINT : PRINT "Border style must be in the range 1-4"
  133.         STOP
  134.     ELSE
  135.         ON ERROR GOTO 0
  136.     END IF
  137. RESUME NEXT
  138.  
  139. REM $STATIC
  140. FUNCTION countentries% (file AS STRING)
  141.     OPEN file$ FOR INPUT AS #1
  142.     count% = -8
  143.     DO UNTIL EOF(1)
  144.         dummy$ = getline$
  145.         count% = count% + 1
  146.         IF (count% > 0) AND (count% MOD 3 = 0) AND (LEN(dummy$) > 4) THEN ERROR 101
  147.     LOOP
  148.     CLOSE #1
  149.     IF (count% < 0) OR (count% MOD 3 <> 0) THEN ERROR 102
  150.     countentries% = count% / 3
  151. END FUNCTION
  152.  
  153. SUB getentry (thing AS ENTRY)
  154.     thing.choice$ = getline$
  155.     thing.action$ = getline$
  156.     thing.inkkey$ = getline$
  157. END SUB
  158.  
  159. FUNCTION getline$
  160.     LINE INPUT #1, temp$
  161.     getline$ = RTRIM$(LTRIM$(temp$))
  162. END FUNCTION
  163.  
  164. SUB getname (m AS STRING, b AS STRING)
  165.     CONST DEFEXT$ = ".mnu", BATEXT$ = ".btm"
  166.    
  167.     hold$ = LCASE$(LTRIM$(RTRIM$(m$)))
  168.     IF INSTR(hold$, " ") THEN ERROR 104
  169.     IF hold$ = "" THEN ERROR 53
  170.     dot = INSTR(hold$, ".")
  171.    
  172.     IF dot <> 0 THEN
  173.         m$ = LEFT$(hold$, dot - 1)
  174.     ELSE
  175.         m$ = LCASE$(m$)
  176.     END IF
  177.     b$ = m$ + BATEXT$
  178.    
  179.     IF dot = 0 THEN
  180.         m$ = m$ + DEFEXT$
  181.     ELSE
  182.         m$ = hold$
  183.     END IF
  184. END SUB
  185.  
  186.