home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / BASIC / GLIB14.ZIP / GLIBDEMO.BAS < prev    next >
Encoding:
BASIC Source File  |  1988-02-06  |  45.0 KB  |  1,377 lines
  1. DECLARE SUB DIR (mask$, fil$())
  2. '+-------------------------[ READ ME ]------------------------------+
  3. '  To start the demo, read the instructions below to make sure it
  4. '  is set up for your QB implementation, and start it with:
  5. '
  6. '  QB4:  QB glibdemo /L GLIB14 /cmd /NC (or /C) /qwerty foobar /1 /B
  7. '     /NC /C is Color - No Color parameter, the rest of the command
  8. '                       line is for demonstration purposes.
  9. ' -----------------------------------------------------------------+
  10. COMMON /fedvars/ fg%, bg%, fgd%, bgd%, bleep%, edt%, nums%, num$, upcase%
  11.  
  12.  
  13. ' The folowing includs all the GLIB DECLARE statements
  14. REM $INCLUDE: 'GLIB14.INC'
  15.  
  16.  
  17.  
  18. '+----------------------------------------
  19. '| GLIBDEMO
  20. '|
  21. '| Demo of key routines in GIZLIB
  22. '| Copr.  InfoSoft 1986-1987, 1988
  23. '+----------------------------------------
  24. '| This demo will demonstrate some of the
  25. '| routines of the QuickBASIC Library that
  26. '| should accompany it.
  27. '| Additionally it will augment the DOCs with its actual use.
  28. '+----------------------------------------
  29. CLEAR
  30. DEFINT A-Z
  31. OPTION BASE 1
  32.  
  33. REM $DYNAMIC
  34.    REDIM sarry%(14001)           ' array to save screns to: holds 7
  35. REM $STATIC
  36.  
  37. GOSUB set.pointers         ' __MUST__ be dynamic
  38.  
  39. quote$ = CHR$(34): clr$ = SPACE$(78)
  40.  
  41. 'make sure it is set up right
  42.  
  43. chkset:
  44. CLS : SOUND 750, 2: LOCATE 5, 5
  45. PRINT "Depending on your display, you may want to restart this demo"
  46. LOCATE 7, 5
  47. PRINT "with the command line parameter [/CMD /NC] to supress color."
  48. LOCATE 10, 5
  49. PRINT "Tap `S' to stop the demo, any other key to continue."
  50.  
  51. ky$ = INKEY$
  52. WHILE ky$ = ""
  53.    ky$ = INKEY$
  54. WEND
  55. PRINT ky$
  56.  
  57. IF ky$ = "S" OR ky$ = "s" THEN
  58.    ky$ = ""
  59.    GOTO extt
  60. END IF
  61.  
  62. '*********** get command line parms and set colors
  63. DIM arg$(6): q% = 0
  64.  
  65. FOR x = 1 TO 6
  66.   arg$(x) = SPACE$(LEN(COMMAND$) / 2)
  67. NEXT x
  68. CALL cmdline(arg$(), q%)
  69.  
  70. IF arg$(1) = "/NC" THEN
  71.    cmode = 0
  72.    fg = 7: bg = 0
  73.    fge = 15: bge = 0
  74.    fgw = 0: bgw = 7
  75.    fgs = 7: bgs = 0
  76.    fgt = 15: fgd = 15
  77. ELSE
  78.    cmode = 1
  79.    fg = 3: bg = 0
  80.    fge = 12: bge = 3
  81.    fgw = 14: bgw = 4
  82.    fgs = 11: bgs = 0
  83.    fgt = 10: fgd = 14
  84. END IF
  85.  
  86. eattr = (bge * 16) + fge
  87. wattr = (bgw * 16) + fgw
  88. attr = (bg * 16) + fg
  89. done = 0
  90.  
  91. IF q = 0 THEN        ' used in the demo of cmdline
  92.        arg$(2) = "No command line entered."
  93. END IF
  94.  
  95.  
  96. DO
  97.     CLS : LOCATE 1, 27
  98.     COLOR fgw, bgw: PRINT "[ GizLib Version 1.4 Demo ]"
  99.     PRINT : COLOR fgs, 0: PRINT TAB(30); " For QuickBASIC 4.0 "
  100.  
  101.     LOCATE 8, 5: COLOR fgd, 0
  102.     PRINT TAB(5); " A - BOXES              I - ERRMSG             Q - PRTSCRN, PTRCTRL "
  103.     PRINT TAB(5); " B - CHRP               J - EXIST  *           R - QUIKPRT"
  104.     PRINT TAB(5); " C - CMDLINE            K - FUNIQ  *           S - SINFO, CPUINFO, MISC"
  105.     PRINT TAB(5); " D - DATE / DFRMAT      L - GETCH, VFNAME **   T - SCROLL, SCROLLER "
  106.     PRINT TAB(5); " E - DIR, FILCNT        M - LCOUNT *           U - TFRMAT / SYSTIME *    "
  107.     PRINT TAB(5); " F - DLY, MDLY          N - NFRMAT             V - SVSCRN, RSTSCRN "
  108.     PRINT TAB(5); " G - DRVSPACE           O - MENUCTRL           W - WDW"
  109.     PRINT TAB(5); " H - DAYOFYR   *        P - PCASE              X - VIDON / VIDOFF *"
  110.     PRINT TAB(5); "                      <Esc>  Ends the demo  ": COLOR fg, bg
  111.     PRINT TAB(15); "   * indicates new function or major enhancement"
  112.  
  113.  
  114.     LOCATE 19, 10: COLOR fgs, bgs
  115.     PRINT "There are MORE routines in the library, than there are in the DEMO, "
  116.     PRINT TAB(10); "like all the MOUSE functions, most of the DOS File Functions etc."
  117.     PRINT
  118.     PRINT TAB(10); "There is even DEMO code in here with no menu selection!"
  119.  
  120. getkey:
  121.     ky$ = INKEY$: WHILE ky$ = "": ky$ = INKEY$: WEND
  122.  
  123.     IF ky$ = CHR$(27) THEN done = 1
  124.     ky$ = UCASE$(ky$)    ' convert to upper for one SELECT object
  125.  
  126.     SELECT CASE ky$
  127.        CASE "A": GOSUB bxs
  128.        CASE "B": GOSUB chrp
  129.        CASE "C": GOSUB cmdl
  130.        CASE "D": GOSUB dformat
  131.        CASE "E": GOSUB ddir
  132.        CASE "F": GOSUB dlys
  133.        CASE "G": GOSUB dspace
  134.        CASE "H": GOSUB daycnt
  135.        CASE "I": GOSUB err.msg
  136.        CASE "J": GOSUB filex
  137.        CASE "K": GOSUB funique
  138.        CASE "L": GOSUB getch.and.vfname
  139.        CASE "M": GOSUB lcountr
  140.        CASE "N": GOSUB num.frmat
  141.        CASE "O": GOSUB menuctrl
  142.        CASE "P": GOSUB pcase
  143.        CASE "Q": GOSUB pscrn
  144.        CASE "R": GOSUB qprt
  145.        CASE "S": GOSUB sysinfo
  146.        CASE "T": GOSUB scrl
  147.        CASE "U": GOSUB tformat
  148.        CASE "V": GOSUB xscrn
  149.        CASE "W": GOSUB wdws
  150.        CASE "X": GOSUB video.junk
  151.        CASE ELSE: IF done = 0 THEN GOTO getkey
  152.     END SELECT
  153.  
  154. LOOP UNTIL done
  155.  
  156.  
  157.  
  158. here:
  159.     SYSTEM
  160.     COLOR fg, bg
  161.     CLS
  162.     GOSUB title
  163.     COLOR fgs, bgs
  164.  
  165. video.junk:
  166.    CLS
  167.    GOSUB title
  168.    COLOR fgs, bgs
  169.  
  170.    LOCATE 5, 15: PRINT "Function: VIDON / VIDOFF - Disable / enable the video"
  171.    LOCATE 6, 15: PRINT "Syntax:  CALL vidon / CALL vidoff"
  172.  
  173.    LOCATE 10, 5: COLOR fg, bg
  174.  
  175.    PRINT TAB(10); "To demo this, we will turn off the display, but beep short, soft"
  176.    PRINT TAB(10); "tones in the background to show that the system is on."
  177.    PRINT
  178.    PRINT TAB(10); "To re - enable the video, tap any key."
  179.  
  180.    GOSUB wait.key
  181.  
  182. video2:
  183.    CALL vidoff
  184.    vky$ = "": vdone = 0                   ' set loop indicator
  185.    cy = 0
  186.  
  187.    DO UNTIL vdone
  188.       CALL dly(2)                        ' delay 2 secs
  189.       vky$ = INKEY$                      ' key waiting?
  190.       IF vky$ > "" THEN vdone = 1        '   yes we are done
  191.       SOUND 1200, .5                     '   no make some noise
  192.  
  193.       cy = cy + 1                        ' I'm bored
  194.       IF cy MOD 2 = 0 THEN PLAY "L64O3AGE"
  195.    LOOP
  196.    CALL vidon
  197.  
  198.    CALL pgetch(" Do it Again? ", 20, 78, "YN", vky$)
  199.    IF vky$ = "Y" THEN GOTO video2
  200.  
  201. RETURN
  202.  
  203. filex:
  204.    CLS : GOSUB title
  205.    LOCATE 5, 15: PRINT "Function: EXIST - Test if a file exists."
  206.    LOCATE 6, 15: PRINT "Syntax:   fil$=" + quote$ + "filename.ext" + quote$
  207.    LOCATE 7, 15: PRINT "          IF exist(fil$) THEN ... "
  208.    LOCATE 8, 15: PRINT "          This FUNCTION MUST be DECLAREd !!"
  209.  
  210.    COLOR fg, bg: LOCATE 10, 10
  211.    PRINT "  This is a simple assembler call to test if the file exists.  This"
  212.    PRINT TAB(10); "is extremely useful in avoiding run time errors in professional"
  213.    PRINT TAB(10); "quality programs."
  214.  
  215.    fil$ = "glibdemo.bas": fil1$ = "foobar.fil"
  216.  
  217.    LOCATE 14, 15: COLOR fgt, 0
  218.    PRINT fil$; " "; : COLOR fg, bg
  219.    IF exist(fil$) THEN PRINT "EXISTS! " ELSE PRINT "is missing!"
  220.  
  221.    LOCATE 16, 15: COLOR fgt, 0               ' hopefully no FOO BAR
  222.    PRINT fil1$; " "; : COLOR fg, bg
  223.    IF exist(fil1$) THEN PRINT "EXISTS! " ELSE PRINT "is missing!"
  224.  
  225.    GOSUB wait.key
  226. RETURN
  227.  
  228.  
  229.  
  230. ddir:
  231.    CLS : GOSUB title
  232.  
  233.    LOCATE 5, 15: PRINT "Function: FILCNT - Number of files matching a mask."
  234.    LOCATE 6, 15: PRINT "Syntax: mask$=" + quote$ + "*.BAS" + quote$ + " : CALL filcnt(mask$, num)"
  235.  
  236.    LOCATE 8, 15: PRINT "Function: DIR - Return matching files in an array."
  237.    LOCATE 9, 15: PRINT "Syntax: DIM file$(num) : file$(1 to num)=SPACE$(12)"
  238.    LOCATE 10, 15: PRINT "        CALL dir(mask$, file$() )"
  239.  
  240.    COLOR fg, bg
  241.    LOCATE 12, 10: PRINT "These 2 tools provide access to filenames much the same as you"
  242.    PRINT TAB(10); "would have from DOS.  FILCNT returns the number of matching files"
  243.    PRINT TAB(10); "primarily for you to DIM the file array to the right size.  Then"
  244.    PRINT TAB(10); "CALLing DIR with the array and mask will return the file names."
  245.    PRINT
  246.    PRINT TAB(10); "Since Assembler routines cannot change string lengths, be SURE to"
  247.    PRINT TAB(10); "initialize your file name array to SPACE$(12)."
  248.  
  249.    GOSUB wait.key
  250.    CLS
  251.    mask$ = "*.*": numf = 0
  252.    CALL filcnt(mask$, numf)
  253.    IF numf <= 5 THEN
  254.       mask$ = "*.*": numf = 0
  255.       CALL filcnt(mask$, numf)
  256.    END IF
  257.    REDIM file$(numf)             ' redim in case we run this again
  258.  
  259.    FOR x = 1 TO numf
  260.        file$(x) = SPACE$(12)
  261.    NEXT x
  262.  
  263. '    +----------------------------------------------------------------+
  264. '    |     In QB 4,  we need not pass the number of                   |
  265. '    |  DIMensions in an array, so select the syntax for the QB       |
  266. '    |  version you are operating under.                              |
  267. '    +----------------------------------------------------------------+
  268.     CALL DIR(mask$, file$())        ' QB 4 Syntax
  269.  
  270.  
  271.    COLOR fgs, 0: LOCATE 2, 25: PRINT numf;
  272.    COLOR fg, bg: PRINT " Files Found in mask "; : COLOR fgs, 0: PRINT mask$
  273.    IF numf > 51 THEN COLOR 7, 0: PRINT TAB(20); "(Only the first 51 will be displayed.)"
  274.  
  275.    LOCATE 5, 1: x = 1
  276.    IF numf > 51 THEN numf = 51           ' prevent screen from scrolling
  277.    lnum = (numf \ 3) * 3       ' set to even loop of #
  278.  
  279.    DO
  280.      COLOR fgs, 0
  281.      PRINT USING "     ##  "; x; : COLOR fg, bg: PRINT file$(x); TAB(30);
  282.      x = x + 1: COLOR fgs, 0
  283.  
  284.      PRINT USING "##  "; x; : COLOR fg, bg: PRINT file$(x); TAB(55);
  285.      x = x + 1: COLOR fgs, 0
  286.  
  287.      PRINT USING "##  "; x; : COLOR fg, bg: PRINT file$(x)
  288.      x = x + 1: COLOR fgs, 0
  289.    LOOP UNTIL x >= lnum
  290.  
  291.    FOR x = lnum + 1 TO numf
  292.      PRINT USING "     ##  "; x; : COLOR fg, bg: PRINT file$(x); SPACE$(5);
  293.      COLOR fgs, 0
  294.    NEXT x
  295.  
  296.  
  297.    GOSUB wait.key
  298. RETURN
  299.  
  300.  
  301. menuctrl:
  302.    CLS : GOSUB title
  303.  
  304.    LOCATE 5, 15: PRINT "Function: MENUCTRL - Accept limited KB input."
  305.    LOCATE 6, 15: PRINT "Syntax: ky=0 : CALL menuctrl(ky) "
  306.    COLOR fg, bg
  307.    LOCATE 8, 10: PRINT "This routine is ideal for menu driven applications.  Using it"
  308.    PRINT TAB(10); "to control, limit or weed out invalid input saves considerable"
  309.    PRINT TAB(10); "code space and time."
  310.    PRINT
  311.    PRINT TAB(10); "MENUCTRL traps for a number or Function Key or Esc ignoring all"
  312.    PRINT TAB(10); "other keystrokes before returning an integer or code indicating"
  313.    PRINT TAB(10); "what was pressed.  The code is simply 1-10 or 15 for Esc.  You"
  314.    PRINT TAB(10); "code can then branch to the correct routines.  MENUCTRL even"
  315.    PRINT TAB(10); "clears the KB buffer prior to the start of the trap."
  316.  
  317.    LOCATE 18, 15: COLOR fgd, 0: mdone = 0: j = 0
  318.    PRINT "Press F1 - F10 or enter a number for demo....<Esc> ends loop."
  319.    DO UNTIL mdone
  320.    CALL menuctrl(j)
  321.    IF j = 15 THEN
  322.       mdone = 1
  323.       EXIT DO
  324.    END IF
  325.    LOCATE 20, 15
  326.    PRINT "You pressed "; j; " or [ F"; j; "]   "
  327.    LOOP
  328.  
  329.    GOSUB wait.key
  330. RETURN
  331.  
  332.  
  333. dspace:   '************************
  334.    CLS : GOSUB title
  335.  
  336.    a% = 0: b% = 0: C% = 0: d% = 0'initialize vars for the call
  337.                              ' a is drive to poll:
  338.                              ' 1=A, 2=B etc 0=Default
  339.  
  340.    CALL drvspace(a%, b%, C%, d%)   ' get drive and free space
  341.    total# = CDBL(a%) * CDBL(C%) * CDBL(d%)
  342.    free# = CDBL(a%) * CDBL(C%) * CDBL(b%)
  343.  
  344.    LOCATE 5, 15: PRINT "Function: DRVSPACE - Get drive info."
  345.    LOCATE 6, 15: PRINT "Syntax:   a%=0:b%=0:c%=0:d%=0 : CALL drvspace(a%,b%,c%,d%) "
  346.    COLOR fg, bg
  347.    LOCATE 8, 15: PRINT "          total#=CDBL(a%)*CDBL(c%)*CDBL(d%)"
  348.    LOCATE 9, 15: PRINT "          free#=CDBL(a%)*CDBL(c%)*CDBL(b%) "
  349.  
  350.    LOCATE 12, 5: PRINT " Also like other LIBs, we can get the size of a drive and/or free space."
  351.    LOCATE 13, 5: PRINT " We have already done it to find:"
  352.    LOCATE 15, 10: PRINT " Total drive space is: "; : COLOR fgs, 0: PRINT total#
  353.    COLOR fg, bg
  354.    LOCATE 17, 10: PRINT " Free space is: "; : COLOR fgs, 0: PRINT free#
  355.  
  356.    GOSUB wait.key
  357. RETURN
  358.  
  359.  
  360.  
  361. sysinfo:       '*************************
  362.    CLS : GOSUB title
  363.  
  364.    ram = 0: ser = 0: par = 0: vga = 0
  365.    CALL sinfo(ram, ser, par, ega, vga)
  366.  
  367.    LOCATE 4, 15: PRINT "Function: SINFO - Get general system info."
  368.    LOCATE 5, 15: PRINT "Syntax: ram=0 : ser=0 : par=0 : ega=0 : vga=0"
  369.    LOCATE 6, 15: PRINT "CALL sinfo(ram, ser, par, ega, vga)"
  370.  
  371.    LOCATE 8, 15: PRINT "Function: CPUINFO - Get specific CPU info."
  372.    LOCATE 9, 15: PRINT "Syntax: idcod%=0 : mhz%=0 : cpu%=0 : ndp%=0"
  373.    LOCATE 10, 15: PRINT "CALL cpuinfo(idcod, cpu, ndp)"
  374.  
  375.    COLOR fg, bg
  376.    idcod = 0: mz = 0: cpu% = 0: ndp% = 0
  377.    CALL cpuinfo(idcod, cpu, ndp)
  378.  
  379.    drv$ = " ": CALL getdrv(drv$)
  380.    switch = 0: CALL getverfy(switch)
  381.  
  382.    LOCATE 12, 10: PRINT "Testing CPU speed..."
  383.    'CALL mhz(mz)
  384.  
  385.    LOCATE 12, 50: COLOR fgs, 0: PRINT "Misc:"
  386.    LOCATE 13, 50: COLOR fg, 0: PRINT "Current Drive: ";
  387.    COLOR fgs, 0: PRINT drv$
  388.    LOCATE 14, 50: COLOR fg, 0: PRINT "Verify Setting: ";
  389.    COLOR fgs, 0
  390.    IF switch THEN PRINT "ON" ELSE PRINT "OFF"
  391.  
  392.    LOCATE 12, 10: COLOR fgs, 0: PRINT "SINFO:                ": COLOR fg, 0
  393.    LOCATE 13, 10: PRINT "RAM installed :"; : COLOR fgs, 0: PRINT ram%: COLOR fg, 0
  394.    LOCATE 14, 10: PRINT "# Serial ports:"; : COLOR fgs, 0: PRINT ser%: COLOR fg, 0
  395.    LOCATE 15, 10: PRINT "Parallel ports:"; : COLOR fgs, 0: PRINT par%: COLOR fg, 0
  396.    LOCATE 16, 10: PRINT "EGA memory    :"; : COLOR fgs, 0: PRINT ega%: COLOR fg, 0
  397.    LOCATE 17, 10: PRINT "VGA installed?: "; : COLOR fgs, 0:
  398.    IF vga THEN PRINT "Yes" ELSE PRINT "No"
  399.    COLOR fgs, 0
  400.  
  401.    LOCATE 19, 10: PRINT "CPUINFO:  "
  402.    COLOR fg, 0
  403.    LOCATE 20, 10: PRINT "Type CPU installed: "; : COLOR fgs, 0: PRINT "80 -"; cpu%: COLOR fg, 0
  404.    LOCATE 21, 10: PRINT "Type NDP installed: "; : COLOR fgs, 0
  405.    IF ndp > 0 THEN PRINT ndp% ELSE PRINT "None"
  406.    COLOR fg, 0
  407.    LOCATE 22, 10: PRINT "Approx. Effec. Mhz: "; : COLOR fgs, 0: PRINT mz / 100: COLOR fg, 0
  408.    LOCATE 23, 10: PRINT "BIOS machine code : "; : COLOR fgs, 0: PRINT idcod;
  409.    SELECT CASE idcod%
  410.        CASE 255: PRINT " (PC class)"
  411.        CASE 254: PRINT " (XT class)"
  412.        CASE 253: PRINT " (PCjr )"
  413.        CASE 252: PRINT " (286 class machine)"
  414.        CASE 249: PRINT " (Convertible)"
  415.        CASE 250: PRINT " (PS/2 Model 30)"
  416.        CASE 251: PRINT " (PS/2 Model 40)"
  417.        CASE 252: PRINT " (PS/2 Model 50-60)"
  418.        CASE 248: PRINT " (PS/2 Model 80 or 386 Class)"
  419.        CASE ELSE: PRINT " (Unknown to me!)"
  420.    END SELECT
  421.    COLOR fg, 0
  422.  
  423.    GOSUB wait.key
  424. RETURN
  425.  
  426.  
  427. dformat:
  428.    CLS : GOSUB title
  429.  
  430.    LOCATE 5, 15: PRINT "Function: DATE - Returns system date info."
  431.    LOCATE 6, 15: PRINT "Syntax: mon=0 : day=0 : yr=0 : dow=0 "
  432.    LOCATE 7, 15: PRINT "CALL date(mon%, day%, yr%, dow%)"
  433.  
  434.    LOCATE 9, 15: PRINT "Function: DFRMAT - Formats a date."
  435.    LOCATE 10, 15: PRINT "Syntax: m=[1-12] : d=[1-31] : y=[1800+] "
  436.    LOCATE 11, 15: PRINT "CALL dfrmat(m%, d%, yr%, nudate$)"
  437.  
  438.    COLOR fg, bg: m = 0: d = 0: y = 0: dow = 0
  439.    CALL date(m%, d%, yr%, dow%)
  440.    CALL dfrmat(m%, d%, yr%, nudate$)
  441.  
  442.    LOCATE 13, 10: PRINT "These allow you to easily put a more friendly face on"
  443.    LOCATE 14, 10: PRINT "BASIC's DATE$, and DATE allows access to the system"
  444.    LOCATE 15, 10: PRINT "date as held in BIOS including the day of the week."
  445.  
  446.    LOCATE 16, 10: PRINT "Today's DATE$ is "; : COLOR fgs, 0: PRINT DATE$: COLOR fg, bg
  447.    LOCATE 17, 10: PRINT "DFRMAT freshens it to :"; : COLOR fgs, 0: PRINT nudate$
  448.    COLOR fg, bg
  449.    LOCATE 19, 10: PRINT "Since DFRMAT works off integers, you can easily format a"
  450.    LOCATE 20, 10: PRINT "string for days gone by, and to easily and quickly get todays"
  451.    LOCATE 21, 10: PRINT "date in integer format, use the routine DATE."
  452.  
  453.    GOSUB wait.key
  454. RETURN
  455.  
  456.  
  457.  
  458. daycnt:
  459.    CLS : GOSUB title
  460.  
  461.    LOCATE 5, 15: PRINT "Function: DAYOFYR - Get day count for this year"
  462.    LOCATE 6, 15: PRINT "Syntax:   DECLARE FUNCTION dayofyr% "
  463.    LOCATE 7, 15: PRINT "          today = dayofyr"
  464.  
  465.  
  466.    COLOR fg, bg
  467.    today = dayofyr
  468.  
  469.    LOCATE 10, 10: PRINT "So far this year there have been";
  470.    COLOR fgs, 0: PRINT today; : COLOR fg, bg: PRINT "days."
  471.  
  472.    COLOR fg, bg: LOCATE 12, 10
  473.    PRINT "DAYOFYR is accurate until Feb 28, 2100 which will be a"
  474.    PRINT TAB(10); "centennial skip-leap year if all goes well."
  475.  
  476.  
  477.    GOSUB wait.key
  478. RETURN
  479.  
  480.  
  481. tformat:
  482.    CLS : GOSUB title
  483.  
  484.    LOCATE 5, 15: PRINT "Function: TFRMAT - Format BASIC's TIME$"
  485.    LOCATE 6, 15: PRINT "Syntax: label%=[0/1] : nutime$=TIME$"
  486.    LOCATE 7, 15: PRINT "CALL tfrmat(nutime$, label% )"
  487.    LOCATE 9, 15: PRINT "Function: SYSTIME - Get system time"
  488.    LOCATE 10, 15: PRINT "Syntax:   CALL systime(hrs%, mins%, sec%, hh%)"
  489.  
  490.  
  491.    COLOR fg, bg
  492.    nutime0$ = TIME$: CALL tfrmat(nutime0$, 0)
  493.    nutime1$ = TIME$: CALL tfrmat(nutime1$, 1)
  494.  
  495.    LOCATE 12, 10: PRINT "We can cleanup BASIC's time output to a cleaner,";
  496.    PRINT TAB(10); "more professional display with simple call."
  497.    PRINT
  498.  
  499.    PRINT TAB(10); "The current time is: "; TIME$
  500.    PRINT TAB(10); "TFRMAT freshens it to :"; : COLOR fgs, 0: PRINT nutime0$;
  501.    COLOR fg, bg: PRINT "  Or to "; : COLOR fgs, 0: PRINT nutime1$
  502.    COLOR fg, bg: LOCATE 17, 10: PRINT "Notice the option of an am/pm label."
  503.  
  504.    CALL systime(hrs, mins, sec, hh)
  505.    LOCATE 20, 5
  506.    PRINT "SYSTIME reports time integers (hrs, mins, sec, hh) as: ";
  507.    COLOR fgs, bgs: PRINT hrs; mins; sec; hh
  508.    COLOR fg, bg
  509.    PRINT TAB(15); "Note that the hundredths may not be accurate on all systems."
  510.  
  511.    GOSUB wait.key
  512. RETURN
  513.  
  514. pcase:
  515.    CLS : GOSUB title
  516.  
  517.    LOCATE 5, 15: PRINT "Function: PCASE - Format string to Proper Case."
  518.    LOCATE 6, 15: PRINT "Syntax:   CALL pcase(text$)"
  519.    COLOR fg, bg: ky$ = "": text$ = ""
  520.  
  521.    LOCATE 9, 10: PRINT "This routine converts incoming or other text to Proper"
  522.    LOCATE 10, 10: PRINT "Case (first letter each word). The text to convert "
  523.    LOCATE 11, 10: PRINT "must passed in lower case, easy in QB 4."
  524.  
  525.    LOCATE 13, 1: PRINT "Please type in a few words of text and tap ENTER. "
  526.  
  527.    lin = 14: max = 25: GOSUB get.string
  528.   '   text$=lcase$(text$)
  529.    CALL pcase(text$)           ' convert to Proper Case
  530.    LOCATE 20, 5: PRINT "Output from PCASE: "; : COLOR fgs, 0: PRINT text$: COLOR fg, bg
  531.  
  532.    LOCATE 22, 5: PRINT "These leave non alpha characters alone, and do NOT choke on Null strings."
  533.  
  534.    GOSUB wait.key
  535. RETURN
  536.  
  537.  
  538. err.msg:
  539.    CLS : GOSUB title
  540.  
  541.    LOCATE 5, 15: PRINT "Function: ERRMSG - Allows you to 'flash' a message to the screen."
  542.    LOCATE 6, 15: PRINT "Syntax: emsg$=" + quote$ + "Text to display. " + quote$ + " emsgline=[any line]"
  543.    LOCATE 7, 15: PRINT "        emsgattr=[(fore*16) + back ] : emsgsnd=[0/1]"
  544.    LOCATE 8, 15: PRINT "CALL errmsg(emsg$, emsgline, emsgattr, emsgsnd)"
  545.    COLOR fg, bg: eml = 22: ems% = 2: max = 35
  546.  
  547.    LOCATE 10, 10: PRINT "What ERRMSG does, is save the display on the screen, display"
  548.    LOCATE 11, 10: PRINT "your message, centered, on the line you tell it, sounds a low "
  549.    LOCATE 12, 10: PRINT "tone if you desire, waits 2 secs, then pops the original display"
  550.    LOCATE 13, 10: PRINT "back onto the screen without you having to redraw it."
  551.  
  552.    LOCATE 15, 5: PRINT "Type in a line to use as an error message or <ENTER> for the demo's own."
  553.    lin = 16'*******************************************
  554.    GOSUB get.string
  555.    IF LEN(text$) < 2 THEN text$ = " Ooops, an error! - You entered no text!"
  556.    CALL errmsg(text$, eml%, eattr%, ems%)
  557.  
  558.    GOSUB wait.key
  559. RETURN
  560.  
  561.  
  562. dollarf:
  563.  
  564. RETURN
  565.  
  566.  
  567. lcountr:
  568.  
  569.    CLS : GOSUB title
  570.  
  571.    LOCATE 5, 15: PRINT "Function: LCOUNT - VERY quickly count lines in a text file."
  572.    LOCATE 6, 15: PRINT "Syntax:   DECLARE FUNCTION lcount%(fhandle%)"
  573.    LOCATE 7, 15: PRINT "          NumLines = lcount(fhandle)"
  574.  
  575.    COLOR fg, bg
  576.  
  577.    LOCATE 9, 10: PRINT "We will attempt to count the lines in GLIB14.DOC, and"
  578.    LOCATE 10, 10: PRINT "if it does not exist, it will try GLIBDEMO.BAS.  If"
  579.    PRINT TAB(10); "this demo is in the binary 'quick save' format, it will return"
  580.    PRINT TAB(10); "an oddball count.  Do a SAVE AS text for accuracy if GLIB14.DOC"
  581.    PRINT TAB(10); "is not in the current directory."
  582.  
  583.    GOSUB wait.key
  584.    LOCATE 15, 1
  585.    IF exist("glib14.doc") THEN
  586.      fil$ = "glib14.doc"
  587.    ELSE
  588.      fil$ = "glibdemo.bas"
  589.    END IF
  590.  
  591.    t1! = TIMER
  592.    ercode = fopen(fil$, 0, fhandle)
  593.    totallines = lcount(fhandle)
  594.    t2! = TIMER
  595.    elaps! = t2! - t1!
  596.  
  597.    PRINT : PRINT
  598.    PRINT TAB(15); fil$; " was tested and found to have";
  599.    COLOR fgs, bgs
  600.    PRINT totallines
  601.    COLOR fg, bg
  602.    PRINT TAB(15); "and processing took a paltry ";
  603.    COLOR fgs, bgs: PRINT USING "#.###"; elaps!;
  604.    COLOR fg, bg: PRINT " seconds."
  605.  
  606.    GOSUB wait.key
  607.  
  608. RETURN
  609.  
  610. num.frmat:
  611.    CLS : GOSUB title
  612.  
  613.    LOCATE 5, 15: PRINT "Function: NFRMAT - Allows you to formatting of numeric strings."
  614.    PRINT TAB(15); "          Formats to phone and social security number formats."
  615.    LOCATE 7, 15: PRINT "Syntax: num$="; quote$; 12345; quote$; " : mode%=[0|1|2|3|4|5|6]"
  616.    LOCATE 8, 15: PRINT "        p=<place to put '-' in mode 6>"
  617.  
  618.    COLOR fg, bg
  619.    LOCATE 10, 10: PRINT "Mode 0 - Disallows '-' as an element.'"
  620.    PRINT TAB(10); "Mode 1 - allows '-' as an element."
  621.    PRINT TAB(10); "Mode 2 - formats to 7 digit phone: xxx-xxxx"
  622.    PRINT TAB(10); "Mode 3 - formats to 10 digit phone: xxx-xxx-xxxx"
  623.    PRINT TAB(10); "Mode 4 - formats to social security format: xxx-xx-xxxx"
  624.    PRINT TAB(10); "Mode 5 - extarcts numbers from string - no exclusions."
  625.    PRINT TAB(10); "Mode 6 - formats to account number style."
  626.    PRINT TAB(10); "         p points to location of '-' in returned string.": COLOR 7, 0
  627.    PRINT TAB(10); "(Tapping Enter feeds the NFRMAT error message directly to ERRMSG)."
  628.    COLOR fg, bg
  629.  
  630.    LOCATE 20, 10: PRINT "Enter seven digits for a phone number:      "
  631.    max = 15: lin = 21
  632.    GOSUB get.string
  633.    m = 2: mm = 2
  634.    GOSUB nflabel
  635.  
  636.    LOCATE 20, 10: PRINT "Enter 10 digits for a phone number:          "
  637.    GOSUB get.string
  638.    m = 3: mm = 3
  639.    GOSUB nflabel
  640.  
  641.    LOCATE 20, 10: PRINT "Enter 11 digits for a social security number:"
  642.    GOSUB get.string
  643.    m = 4: mm = 4
  644.    GOSUB nflabel
  645.  
  646.    LOCATE 20, 10: PRINT "Enter some digits as if an account number:   "
  647.    GOSUB get.string
  648.    m = 6: mm = 6: p = 3
  649.    GOSUB nflabel
  650.  
  651.    GOTO nf.end
  652.  
  653. nflabel:
  654.    CALL nfrmat(text$, m, p)
  655.    IF m = mm THEN
  656.       LOCATE 21, 20: PRINT "Mode "; m; " output "; text$
  657.    ELSE
  658.       CALL errmsg(text$, 24, eattr, 1)
  659.       LOCATE lin, 1: PRINT clr$;
  660.       text$ = ""
  661.    END IF
  662.    GOSUB wait.key
  663.    FOR x = 19 TO 25
  664.       LOCATE x, 1
  665.       PRINT clr$;
  666.    NEXT x
  667.  RETURN
  668.  
  669. nf.end:
  670.     BEEP
  671.    GOSUB wait.key
  672.  
  673. RETURN
  674.  
  675. chrp:
  676.    CLS : GOSUB title
  677.    LOCATE 5, 15: PRINT "Function: CHRP - Produce a simple Chirp."
  678.    LOCATE 6, 15: PRINT "          0-descending 1-ascending."
  679.    LOCATE 7, 15: PRINT "Syntax: CALL chrp(1) <or> CALL chrp(0) "
  680.    LOCATE 8, 15: PRINT "        Alternative: n=[0 | 1] : CALL chrp(n%) "
  681.  
  682.    COLOR fg, bg
  683.    LOCATE 11, 10: PRINT "The descending tone is suitable for emulating a"
  684.    PRINT TAB(10); "psuedo closing sound for window removal."
  685.    COLOR fgs, 0
  686.  
  687.    y = 1: LOCATE 13, 10
  688.    FOR x = 1 TO 3
  689.       LOCATE 13 + x, 10: PRINT "Ascending ...";
  690.       CALL chrp(1)
  691.       CALL dly(1)
  692.       PRINT "    Descending ...";
  693.       CALL chrp(0)
  694.       CALL dly(1)
  695.    NEXT x
  696.  
  697.    GOSUB wait.key
  698. RETURN
  699.  
  700.  
  701. dlys:
  702.    CLS : GOSUB title
  703.    LOCATE 5, 15: PRINT "Function: DLY - Produce a delay for x seconds."
  704.    LOCATE 6, 15: PRINT "Syntax: CALL dly(1) <or> CALL dly(0) "
  705.    LOCATE 7, 15: PRINT "        Alternative: n=[0 | 1] : CALL dly(n%) "
  706.  
  707.    LOCATE 10, 15: PRINT "Function: MDLY - Produce a delay for x milli-seconds."
  708.    LOCATE 11, 15: PRINT "Syntax: CALL mdly(500)"
  709.    LOCATE 12, 15: PRINT "        Alternative: n=500 : CALL mdly(n%) "
  710.  
  711.    COLOR fg, bg: LOCATE 15, 10
  712.    PRINT "Delay for 3 seconds:"; TIMER; "   ";
  713.    CALL dly(3)
  714.    PRINT TIMER
  715.  
  716.    LOCATE 17, 10
  717.    PRINT "Delay for 500 milli secs (approx .5 secs): "; TIMER;
  718.    CALL mdly(500): PRINT TIMER
  719.  
  720.    LOCATE 18, 10
  721.    PRINT "Delay for 1000 milli secs (approx 1 secs): "; TIMER;
  722.    CALL mdly(1000): PRINT TIMER
  723.  
  724.    GOSUB wait.key
  725. RETURN
  726.  
  727.  
  728. getch.and.vfname:
  729.    CLS : GOSUB title
  730.  
  731.    LOCATE 5, 15: PRINT "Function: GETCH - Allow Input only from predefined string."
  732.    LOCATE 6, 15: PRINT "Syntax: ky$=" + quote$ + " " + quote$ + ": okay$=" + quote$ + "ABCDEF" + quote$
  733.    LOCATE 8, 15: PRINT "        CALL getch(okay$, ky$)"
  734.  
  735.    COLOR fg, bg
  736.    LOCATE 10, 5: PRINT "Select any odd number (all other input ignored): "
  737.    num$ = "13579": ky$ = " "
  738.    CALL getch(num$, ky$)
  739.    COLOR fgs, bgs
  740.    PRINT TAB(15); "You selected "; ky$
  741.  
  742.    COLOR fg, bg
  743.    PRINT : PRINT TAB(10); "Do you understand how this works? (Y/N)? ";
  744.    yorn$ = "YN"
  745.    CALL getch(yorn$, ky$)
  746.    COLOR fgs, bgs
  747.    PRINT ky$: PRINT TAB(10);
  748.  
  749.    SELECT CASE ky$
  750.     CASE "Y": PRINT "Good, I am glad you do."
  751.     CASE "N": PRINT "Well, too bad for you!"
  752.     CASE ELSE: PRINT "Demo Code has been violated"
  753.    END SELECT
  754.  
  755.    xdone = 0
  756.    DO UNTIL xdone
  757.      LOCATE 16, 15: COLOR fgs, bgs
  758.      PRINT "Type a name that MIGHT or MIGHT not be capable of"
  759.      PRINT TAB(15); "being a legal DOS name: ";
  760.      fsiz = 12: fil$ = ""
  761.      CALL fed(fil$, fsiz, fcode)            ' whoa! he uses it!
  762.      fil$ = LTRIM$(RTRIM$(fil$))            ' we know a space is illegal
  763.      invalchar = 0: doscode = 0             ' this is in a loop
  764.      invalchar = vfname(fil$, doscode)
  765.      LOCATE 18, 15
  766.      IF invalchar THEN PRINT "Nope, "; quote$; CHR$(invalchar); quote$; " is illegal."
  767.  
  768.      SELECT CASE doscode                 ' was there a DOS error
  769.         CASE 0    ' do nothing - no error
  770.         CASE 1: PRINT "odd error"
  771.         CASE 3: PRINT "path or drive illegal"
  772.         CASE 5: PRINT "access denied!"
  773.         CASE ELSE: PRINT "nope - no can do!"
  774.      END SELECT
  775.  
  776.      CALL pgetch(" Test another filename? ", 20, 78, yorn$, ky$)
  777.      IF ky$ = "Y" THEN                ' clear part of screen
  778.         FOR x = 15 TO 24
  779.           LOCATE x, 1
  780.           PRINT SPACE$(79);
  781.         NEXT x
  782.      ELSE
  783.         xdone = 1
  784.      END IF
  785.  
  786.    LOOP
  787.  
  788.    GOSUB wait.key
  789.  
  790. RETURN
  791.  
  792.  
  793. sdump:
  794.    CLS : GOSUB title
  795.  
  796.    LOCATE 5, 15: PRINT "Function: SCRNDUMP - Send current display to disk."
  797.    LOCATE 6, 15: PRINT "Syntax:   fil.num=x : CALL scrndump(fil.num%) "
  798.  
  799.    LOCATE 9, 10: COLOR fg, bg
  800.    PRINT "   With SCRNDUMP, you can dump the screen display to disk."
  801.    PRINT TAB(10); "SCRNDUMP is very versatile in that by passing the file number,"
  802.    PRINT TAB(10); "you have control over whether the display is APPENDed to a file"
  803.    PRINT TAB(10); "already open or whether a new file is started with the SCRNDUMP."
  804.  
  805.     LOCATE 14, 20: PRINT "Examples of APPEND and non APPEND mode: "
  806.     LOCATE 15, 10: PRINT "210: OPEN "; quote$; "SCREEN.FIL"; quote$; "FOR APPEND AS #3   <or> "
  807.     LOCATE 16, 10: PRINT "210: OPEN "; quote$; "SCREEN.FIL"; quote$; "FOR OUTPUT AS #3"
  808.     PRINT TAB(10); "220: CALL scrndump(3) "
  809.  
  810.     PRINT : ky$ = ""
  811.     PRINT TAB(10); "Press any key, we will dump this screen to a"
  812.     PRINT TAB(10); "file called SCRNDUMP.FIL, you can examine later."
  813.     WHILE ky$ = ""
  814.       ky$ = INKEY$
  815.     WEND
  816.  
  817.     OPEN "scrndump.fil" FOR OUTPUT AS #1
  818.     BEEP: CALL scrndump(1)
  819.     CLOSE #1
  820.     COLOR fgs, bgs
  821.     LOCATE 10, 15: PRINT "SCRNDUMP.FIL contains the screendump just executed."
  822.  
  823.     GOSUB wait.key
  824. RETURN
  825.  
  826.  
  827.  
  828. qprt:
  829.    CLS : GOSUB title
  830.  
  831.    LOCATE 5, 15: PRINT "Function: QUIKPRT - Replacement for BASICA's terribly slow"
  832.    LOCATE 6, 15: PRINT "          PRINT statement."
  833.    LOCATE 7, 15: PRINT "Syntax: msg$="; quote$; "Thing to print"; quote$; " : row=x : col=y : attr=(fg*16)+bg)"
  834.    LOCATE 8, 15: PRINT "        CALL quikprt(msg$, row%, col%, attr%) "
  835.  
  836.    COLOR fg, bg
  837.  
  838.    LOCATE 10, 10: PRINT "This is a VERY, VERY fast replacement for BASIC's native PRINT"
  839.    PRINT TAB(10); "statement that is pitifully slow.  There is a fair amount of set up"
  840.    PRINT TAB(10); "to use this, so it is not ideal for character based output, but for"
  841.    PRINT TAB(10); "string and array output, it speeds things up on an order of MAGNITUDE."
  842.    PRINT TAB(10); "The attribute parameter is caluculated via the formula:"
  843.    PRINT TAB(10); "(FOREGROUND * 16) + BACKGROUND": COLOR fgs, 0
  844.    PRINT TAB(10); "QUIKPRT is also quite smart, recognizing mono and EGA adapters to"
  845.    PRINT TAB(10); "print even FASTER on systems so equipped."
  846.    PRINT : COLOR fg, bg
  847.    PRINT TAB(10); "To demo this, we will fill the screen with characters 10 times using"
  848.    PRINT TAB(10); "PRINT then again using QUIKPRT and then compare the times."
  849.  
  850.    GOSUB wait.key
  851.    CLS
  852.    pstart! = TIMER
  853.    FOR z = 1 TO 10
  854.      FOR x = 1 TO 24
  855.         PRINT STRING$(80, CHR$(47 + z))
  856.      NEXT x
  857.    NEXT z
  858.    pend! = TIMER
  859.  
  860.    CLS : BEEP
  861.  
  862.    qstart! = TIMER
  863.    FOR z = 1 TO 10
  864.       FOR x = 1 TO 24
  865.         CALL quikprt(STRING$(80, CHR$(47 + z)), x, 1, attr%)
  866.       NEXT x
  867.    NEXT z
  868.    qend! = TIMER
  869.  
  870.    pelaps! = pend! - pstart!
  871.    qelaps! = qend! - qstart!
  872.    CLS : LOCATE 10, 1
  873.    PRINT "Elapsed time for PRINT "; pelaps!
  874.    PRINT "Elapsed time for QUIKPRT "; qelaps!
  875.  
  876.    GOSUB wait.key
  877. RETURN
  878.  
  879.  
  880. pscrn:
  881.    CLS : GOSUB title
  882.  
  883.    LOCATE 5, 15: PRINT "Function: PRTSCRN - Send current display to printer."
  884.    LOCATE 6, 15: PRINT "Syntax:   CALL prtscrn "
  885.  
  886.    LOCATE 8, 15: PRINT "Function: PINIT(num) - Initialize printer 1,2 or 3"
  887.    LOCATE 9, 15: PRINT "Syntax:   p=1 : CALL pinit(p)"
  888.  
  889.    LOCATE 8, 15: PRINT "Function: PSTAT(num) - Test if printer is online/ready."
  890.    LOCATE 9, 15: PRINT "Syntax:   p=1 : CALL pstat(p)"
  891.  
  892.    GOSUB wait.key
  893.    LOCATE 24, 1: PRINT clr$;
  894.  
  895.    COLOR fg, bg: ky$ = "": p = 1
  896.  
  897.    LOCATE 11, 10: PRINT "Initialize printer:": CALL pinit(1)
  898.    CALL dly(2)        'wait for it to finish initializing before testing
  899.  
  900.    LOCATE 13, 10: PRINT "Testing printer status:";
  901.    CALL pstat(p)
  902.  
  903.    LOCATE 14, 15: PRINT "Your Printer is ";
  904.    IF p = 0 THEN PRINT "NOT ";
  905.    PRINT "Ready !"
  906.  
  907.    LOCATE 17, 10: INPUT "Perform PRTSCRN demo? (Y/n) ", ky$
  908.    IF ky$ = "N" OR ky$ = "n" THEN GOTO pscrn.end
  909.    IF p = 0 THEN
  910.       PRINT "Can't - it is not online!"
  911.       GOTO pscrn.end
  912.    END IF
  913.  
  914.    CALL prtscrn
  915.  
  916. pscrn.end:
  917.    GOSUB wait.key
  918.  
  919. RETURN
  920.  
  921.  
  922. cmdl:
  923.    CLS : GOSUB title
  924.  
  925.    LOCATE 5, 15: PRINT "Function: CMDLINE  - Retrieve and parse any command line"
  926.    LOCATE 6, 15: PRINT "                     parameters."
  927.    LOCATE 7, 15: PRINT "Syntax:   DIM arg$(x) : q=y "
  928.    LOCATE 8, 15: PRINT "          CALL cmdline(arg$(),q%) "
  929.  
  930.    COLOR fg, bg
  931.    LOCATE 10, 10: PRINT "DIMension the array that will hold the arguments preferably to"
  932.    PRINT TAB(10); "a size one or 2 larger than the total number of arguments your program"
  933.    PRINT TAB(10); "expects or allows.  Q is set to 0 or 1 depending on your OPTION BASE"
  934.    PRINT TAB(10); "to tell CMDLINE where to put the first argument, element 0 or 1. OPTION"
  935.    PRINT TAB(10); "BASE 1 can be emulated here by setting Q to 1; Q returns the actual"
  936.    PRINT TAB(10); "number passed, to aid in FOR...NEXT loop analysis in your program."
  937.    PRINT
  938.    PRINT TAB(10); "If you started this demo from the batch file provided, the demo of this"
  939.    PRINT TAB(10); "routine will display the first 6 command line parameters passed from"
  940.    PRINT TAB(10); "that batch file (that is all I expect)."
  941.  
  942.   ' DIM arg$(6) : q=6             (this was already done and read
  943.   ' CALL cmdline(arg$(),q)        earlier - see the code at the start)
  944.  
  945.    GOSUB wait.key
  946.    CLS : LOCATE 5, 10
  947.    PRINT "In OPTION BASE 1, q returns the quatity of args AND high array"
  948.    PRINT TAB(10); "Dimension filled. In OPTION BASE 0 q returns only the"
  949.    PRINT TAB(10); "number of arguments, the last element = Q+1 as with"
  950.    PRINT TAB(10); "most OPTION BASE 0 operations."
  951.  
  952.    IF q > 0 THEN    ' in case they were removed
  953.       LOCATE 10, 10: PRINT "Actual number of arguments present: "; q
  954.       PRINT
  955.       PRINT TAB(10); "Arguments passed:"
  956.         ' start with LBOUND so you can test OPTION BASE 0
  957.       FOR x = LBOUND(arg$) TO q
  958.       PRINT TAB(15); "Argument "; x; ": "; arg$(x)
  959.       NEXT
  960.    ELSE
  961.       LOCATE 10, 10: PRINT "Demo was started with no command line."
  962.    END IF
  963.  
  964.    GOSUB wait.key
  965. RETURN
  966.  
  967.  
  968.  
  969. xscrn:
  970.    CLS : GOSUB title
  971.  
  972.    LOCATE 5, 15: PRINT "Function: SVSCRN, RSTSCRN - Save the current video display to"
  973.    LOCATE 6, 15: PRINT "          an integer array and Restore it later when desired."
  974.    LOCATE 7, 10: PRINT "Syntax:   CALL svscrn(VARSEG(sarry(1)), VARPTR(sarry(1)) )"
  975.  
  976.  
  977.    COLOR fg, bg
  978.    LOCATE 11, 5: PRINT "These routines allow you to save and restore a screen image."
  979.    PRINT TAB(5); "If you are not familiar with VARPTR, refer to it in the QB book."
  980.    PRINT TAB(5); "Study the docs carefully before using these. Improper set up will"
  981.    PRINT TAB(5); "send the machine on a search for Spock."
  982.    PRINT
  983.    PRINT TAB(5); "   Each screen to save requires 2000 bytes in an array, so to save 3, DIM"
  984.    PRINT TAB(5); "it to 6000 bytes.  The method used here, utilizes DYNAMIC memory, which"
  985.    PRINT TAB(5); "means it resides outside the local segment.  In so doing, the routine will"
  986.    PRINT TAB(5); "require that we pass a pointer to the array's SEGMENT as well as the first"
  987.    PRINT TAB(5); "element to use.  This is done with the VARSEG function, and VARPTR for the "
  988.    PRINT TAB(5); " pointer to the first element. The demo for this is integrated"
  989.    PRINT TAB(5); "into the next demo but feel free to examine this code for additional info.";
  990.  
  991.    GOSUB wait.key
  992.  
  993. wdws:
  994.    CLS : GOSUB title
  995.    LOCATE 5, 15: PRINT "Function: WDW - Pop a window to the screen with sound "
  996.    LOCATE 6, 15: PRINT "                and color control."
  997.    LOCATE 7, 15: PRINT "Syntax: top=n : rt=n : btm=n : lft=n : sfx=0/1 : gro=0/1 "
  998.    LOCATE 8, 15: PRINT "        grame=x; attr=(fg*16)+bg : label$="; quote$; "Window Label"; quote$
  999.    LOCATE 9, 15: PRINT "       CALL wdw(top, lft, btm, rt, sfx, gro, fr, attr, l$)"
  1000.  
  1001.    COLOR fg, bg
  1002.    LOCATE 11, 10: PRINT "The first 4 parameters define the perimeter of the window, while"
  1003.    PRINT TAB(10); "SND and GRO are (0/1) switches that determine if there is to be sound"
  1004.    PRINT TAB(10); "or if the window is to grow.  The attribute is determined in the same"
  1005.    PRINT TAB(10); "manner as it is in QUIKPRT, frame is your choice of frame style, (see"
  1006.    PRINT TAB(10); "the manual for full information). Finally, LABEL$ is a label to center"
  1007.    PRINT TAB(10); "across the top of the window (which can be omitted)."
  1008.    PRINT
  1009.    PRINT TAB(10); "The GROW is quite swift, making it acceptable for use on 8088 based"
  1010.    PRINT TAB(10); "machines, maybe too fast on 286's, but it's an effect not a function."
  1011.  '  PRINT TAB(10) ; "Via a environment switch, you can set sound on and let the end user"
  1012.  '  PRINT TAB(10) ; "override it for maximum flexibility."
  1013.  ' the assembler version no longer supports the environ switch, but it may later
  1014.  
  1015.    GOSUB wait.key
  1016.    wattr2% = (1 * 16) + 15: wattr3% = (2 * 16) + 15: wattr4% = (0 * 16) + 11: wattr5 = (3 * 16) + 0
  1017.    wattr6% = (5 * 16) + 14
  1018.  
  1019. '  DIM sarry%(14000)                     ' This was done earlier to be available
  1020.  
  1021.    GOSUB set.pointers
  1022.  
  1023.    CALL sinfo(j, j, j, ega, vga)      ' a REAL use for this one:
  1024.                                 ' if ega or vga, wdws are REAL fast!
  1025.  
  1026.    CALL svscrn(segmt1, sptr1)       ' now we have the screen with text
  1027.                                    ' captured in array
  1028.    CALL wdw(2, 2, 15, 55, 1, 1, 1, wattr%, "Gro & SFX")
  1029.    IF ega + vga > 0 THEN
  1030.      CALL mdly(250)            ' pause a bit if EGA or VGA
  1031.      LOCATE 8, 5: COLOR fgw, bgw     ' so wdws appear individually
  1032.      PRINT "There is a one tenth second delay"
  1033.      LOCATE 9, 5: PRINT "between each window call for effect."
  1034.      LOCATE 10, 5: PRINT "Untethered, they are even faster!"
  1035.    END IF
  1036.  
  1037.    CALL svscrn(segmt2, sptr2)       ' capturd one with window one on it
  1038.  
  1039.    CALL wdw(12, 5, 23, 30, 0, 0, 2, wattr2%, "No Gro, No SFX")
  1040.    CALL svscrn(segmt3, sptr3)
  1041.    IF ega + vga > 0 THEN CALL mdly(150)
  1042.  
  1043.    CALL wdw(2, 42, 13, 75, 0, 1, 3, wattr3%, "SFX Only")
  1044.    CALL svscrn(segmt4, sptr4)
  1045.    IF ega + vga > 0 THEN CALL mdly(150)
  1046.  
  1047.    CALL wdw(5, 52, 23, 75, 1, 0, 4, wattr4%, "Gro Only")
  1048.    CALL svscrn(segmt5, sptr5)
  1049.    IF ega + vga > 0 THEN CALL mdly(150)
  1050.  
  1051.    CALL wdw(15, 32, 24, 52, 1, 1, 0, wattr5%, "Gro & SFX")
  1052.    CALL svscrn(segmt6, sptr6)
  1053.    IF ega + vga > 0 THEN CALL mdly(150)
  1054.  
  1055.    CALL wdw(2, 2, 6, 22, 0, 1, 3, wattr6%, "SFX Only")
  1056.    CALL svscrn(segmt7, sptr7)
  1057.    CALL mdly(150)
  1058.  
  1059.    COLOR 15, 1
  1060.    LOCATE 13, 6: PRINT "With SVSCRN and RSTSCRN"
  1061.    LOCATE 14, 6: PRINT "we can back up one "
  1062.    LOCATE 15, 6: PRINT "layer at a time..."
  1063.    LOCATE 17, 6: PRINT "I have added a .5 sec"
  1064.    LOCATE 18, 6: PRINT "delay so you see what"
  1065.    LOCATE 19, 6: PRINT "is going on."
  1066.    CALL clrkbd
  1067.    GOSUB wait.key
  1068.  
  1069.    GOSUB set.pointers
  1070.    CALL rstscrn(segmt6, sptr6)              ' pops them back one at a time
  1071.    CALL mdly(500)
  1072.    CALL rstscrn(segmt5, sptr5)
  1073.    CALL mdly(500)
  1074.    CALL rstscrn(segmt4, sptr4)
  1075.    CALL mdly(500)
  1076.    CALL rstscrn(segmt3, sptr3)
  1077.    CALL mdly(500)
  1078.    CALL rstscrn(segmt2, sptr2)
  1079.    CALL mdly(500)
  1080.    CALL rstscrn(segmt1, sptr1)
  1081.  
  1082.    COLOR 15, 1
  1083.    CALL wdw(12, 5, 23, 30, 0, 0, 2, wattr2%, "Window 2")
  1084.    LOCATE 13, 6: PRINT "We still have each level"
  1085.    LOCATE 14, 6: PRINT "of screen in memory, and"
  1086.    LOCATE 15, 6: PRINT "can recall any level we"
  1087.    LOCATE 16, 6: PRINT "chose! "
  1088.    LOCATE 17, 6: PRINT "Let's peel them back "
  1089.    LOCATE 18, 6: PRINT "with sound."
  1090.  
  1091.    GOSUB wait.key
  1092.    GOSUB set.pointers
  1093.  
  1094.    CALL rstscrn(segmt6, sptr6)               ' no window level
  1095.    CALL chrp(0)
  1096.    CALL mdly(500)
  1097.  
  1098.    CALL rstscrn(segmt5, sptr5)
  1099.    CALL chrp(0)
  1100.    CALL mdly(500)
  1101.  
  1102.    CALL rstscrn(segmt4, sptr4)
  1103.    CALL chrp(0)
  1104.    CALL mdly(500)
  1105.  
  1106.    CALL rstscrn(segmt3, sptr3)
  1107.    CALL chrp(0)
  1108.    CALL mdly(500)
  1109.  
  1110.    CALL rstscrn(segmt2, sptr2)
  1111.    CALL chrp(0)
  1112.    CALL mdly(500)
  1113.  
  1114.    CALL rstscrn(segmt1, sptr1)
  1115.    CALL chrp(0)
  1116.  
  1117.    GOSUB wait.key
  1118. RETURN
  1119.  
  1120. bxs:
  1121.    CLS : GOSUB title
  1122.  
  1123.    LOCATE 5, 15: PRINT "Function: BOXES - Pops a frame onto the screen as you might"
  1124.    LOCATE 6, 15: PRINT "          for a menu."
  1125.    LOCATE 7, 15: PRINT "Syntax: box=x : frame=x : foreground=x "
  1126.    LOCATE 8, 15: PRINT "        CALL boxes(box%, frame%, foreground%)"
  1127.  
  1128.    COLOR fg, bg
  1129.  
  1130.    LOCATE 10, 10: PRINT "This is really an attempt on my part to make WDW depend more"
  1131.    PRINT TAB(10); "dependant on asm routines, but even though I am not done with it, I"
  1132.    PRINT TAB(10); "have found a few uses for it.  At point it worked out great for a "
  1133.    PRINT TAB(10); "split screen application I wrote."
  1134.    PRINT TAB(10); "Regardless, less coding and code space is consumed with an ASM CALL"
  1135.    PRINT TAB(10); "even with what is left for you to finish."
  1136.    PRINT
  1137.    PRINT TAB(10); "There are 5 boxes, tap <Enter> at the BEEP to move thru them..."
  1138.  
  1139.    GOSUB wait.key: CLS
  1140.    CALL boxes(1, 1, 15)
  1141.    BEEP: GOSUB waitk2: CLS
  1142.    CALL boxes(2, 2, 14)
  1143.    BEEP: GOSUB waitk2: CLS
  1144.    CALL boxes(3, 3, 3)
  1145.    BEEP: GOSUB waitk2: CLS
  1146.    CALL boxes(4, 4, 4)
  1147.    BEEP: GOSUB waitk2: CLS
  1148.    CALL boxes(5, 1, 11)
  1149.    BEEP: GOSUB waitk2: CLS
  1150.    CALL boxes(6, 1, 11)
  1151.    BEEP: GOSUB waitk2
  1152.  
  1153.    CALL boxes(3, 4, 2)
  1154.    CALL boxes(4, 4, 2)
  1155.  
  1156.    COLOR fg, bg
  1157.    LOCATE 2, 3: PRINT "You can probably imagine how this came in handy on a "
  1158.    LOCATE 3, 3: PRINT "split screen application..."
  1159.    LOCATE 14, 3: PRINT "Yes I can!!"
  1160.    GOSUB wait.key
  1161. RETURN
  1162.  
  1163. scrl:
  1164.    CLS : GOSUB title
  1165.  
  1166.    LOCATE 5, 15: PRINT "Function: USCROLL, DSCROLL - Scroll the display up or down."
  1167.    LOCATE 6, 15: PRINT "Syntax: Num lines [1-24] to scroll and use legal coordinates:"
  1168.    LOCATE 7, 15: PRINT "        CALL USCROLL(num%, top%, lft%, bttm%, rght%)"
  1169.    LOCATE 8, 15: PRINT "        CALL DSCROLL(num%, top%, lft%, bttm%, rght%)"
  1170.  
  1171.    LOCATE 10, 15: PRINT "Function: SCROLLER - Scroll the display left or right."
  1172.    LOCATE 11, 15: PRINT "Syntax: Num lines [1-24] to scroll +(left) or -(right)"
  1173.    LOCATE 12, 15: PRINT "        CALL SCROLLER(-40)"
  1174.    LOCATE 13, 15: PRINT "        CALL SCROLLER(+10)"
  1175.  
  1176.    COLOR fg, bg
  1177.    LOCATE 15, 10: PRINT "This allows us to scroll any legal window any number of lines."
  1178.    PRINT TAB(10); "We will fill the screen with a test pattern and then scroll a window"
  1179.    PRINT TAB(10); "of text within it to demonstrate one of the more impressive aspects of"
  1180.    PRINT TAB(10); "the first routine.  A second demo does a screen left-right scroll demo."
  1181.    PRINT TAB(10); "The area of the screen to be scrolled and the number of lines to"
  1182.    PRINT TAB(10); "scroll is fully user definable."
  1183.  
  1184.    GOSUB wait.key
  1185.    CLS
  1186.  
  1187.    COLOR fgt, 0          ' QUIKPRT a test pattern
  1188.    FOR x = 1 TO 24
  1189.       CALL quikprt(STRING$(80, CHR$(x + 96)), x, 1, 2)
  1190.    NEXT x
  1191.  
  1192.    GOSUB set.pointers
  1193.  
  1194.    BEEP:   CALL svscrn(segmt1, sptr1)         ' save the test pattern
  1195.    COLOR fgd, 0
  1196.  
  1197.    FOR x = 1 TO 15       ' print the text at the
  1198.       CALL uscroll(1, 5, 20, 19, 59)     '  same line, let SCROLL
  1199.       LOCATE 19, 22      '  move the text up the screen
  1200.       PRINT "Scroll Up Line # "; x;
  1201.    NEXT x
  1202.  
  1203.    COLOR fgt, 0: LOCATE 15, 44: PRINT "Slow now, w/"
  1204.    LOCATE 16, 44: PRINT "frame (from WDW)!"
  1205.  
  1206.    GOSUB wait.key         ' wait for you to catch up
  1207.  
  1208.    GOSUB set.pointers
  1209.    CALL rstscrn(segmt1, sptr1)                ' restore test pattern
  1210.  
  1211.    CALL wdw(6, 30, 16, 50, 0, 0, 2, 4, "15 Lines")  'could be done with box #6
  1212.  
  1213.    COLOR fgd, 0
  1214.    FOR x = 1 TO 15        ' loop for 15 lines
  1215.       CALL dscroll(1, 6, 30, 16, 50)      '   scroll down a line
  1216.       LOCATE 6, 31             '   at top of window,....
  1217.       IF cmode THEN COLOR x, 0 ELSE COLOR 15, 0
  1218.       PRINT "Scroll Dn Line #"; x;        '   print the message
  1219.       CALL mdly(500)           '   waitasec
  1220.    NEXT x
  1221.  
  1222.    BEEP
  1223.  
  1224.    CLS : LOCATE 10, 22
  1225.    PRINT "Now, shifting the screen using SCROLLER."
  1226.  
  1227.    GOSUB wait.key
  1228.  
  1229.    GOSUB set.pointers
  1230.    BEEP: CALL rstscrn(segmt1, sptr1)        ' restore test pattern
  1231.  
  1232.    FOR x = 1 TO 6
  1233.         CALL scroller(40)
  1234.         CALL mdly(500)
  1235.         CALL scroller(-40)
  1236.         CALL mdly(500)
  1237.    NEXT x
  1238.    CALL dly(1)
  1239.    CALL rstscrn(segmt1, sptr1)              ' restore test pattern
  1240.  
  1241.    BEEP
  1242.    FOR x = 1 TO 80
  1243.       CALL scroller(-1)
  1244.    NEXT x
  1245.    SOUND 1200, .75
  1246.    LOCATE 15, 25: PRINT "Scrolled lines are lost."
  1247.    CALL dly(1): LOCATE 16, 30: PRINT "Forever"
  1248.  
  1249.    GOSUB wait.key
  1250. RETURN
  1251.  
  1252.  
  1253. funique:
  1254.   CLS : GOSUB title
  1255.  
  1256.   LOCATE 5, 15: PRINT "Function: FUNIQ - Create a unique file (name and HANdle)."
  1257.   LOCATE 6, 15: PRINT "Syntax:   DECLARE FUNCTION funiq(fil$, fhandle%)"
  1258.  
  1259.   COLOR fg, bg
  1260.   LOCATE 10, 10: PRINT "   To demo this, we'll creat a file, tell you the name and"
  1261.   PRINT TAB(10); "handle but leave it on disk for you to look at later.   There will"
  1262.   PRINT TAB(10); "be NOTHING in the file as we have no use for it, but it will be"
  1263.   PRINT TAB(10); "there with 0 bytes. "; ""
  1264.  
  1265.   GOSUB wait.key
  1266.   drv$ = " "                          ' always initialize sting storage
  1267.   CALL getdrv(drv$)                   ' get current drive
  1268.   temp$ = drv$ + ":\" + SPACE$(13)    ' save room for the name
  1269.                  ' this will put it in the root because we did not
  1270.                  ' fetch the current directory
  1271.   ercode = funiq(temp$, 0, fhandle)           ' normal attributes
  1272.   LOCATE 16, 5
  1273.  
  1274.   IF ercode THEN
  1275.     COLOR fgs, bgs
  1276.     PRINT "Ooops, ercode of"; ercode; " means something went wrong."
  1277.   ELSE
  1278.     COLOR fg, bg
  1279.     PRINT " The UNIQUE, temporary or scratch file's name is: ";
  1280.     COLOR fgs, bgs
  1281.     PRINT temp$
  1282.     COLOR fg, bg
  1283.     PRINT TAB(10); "and the other file functions address it as handle: ";
  1284.     COLOR fgs, bgs
  1285.     PRINT fhandle
  1286.   END IF
  1287.  
  1288.   GOSUB wait.key
  1289.   ercode = fclose(fhandle)
  1290. RETURN
  1291.  
  1292. the.end:
  1293.    CALL wdw(10, 10, 20, 70, 1, 1, 1, wattr%, "The End")
  1294.    x = 11: y = 15: COLOR fgw, bgw
  1295.    LOCATE x, y
  1296.    PRINT "      Thanks for your time and interest in GIZLIB."
  1297.    x = x + 2
  1298.    LOCATE x, y:        PRINT "This demo is meant to demonstrate the use and"
  1299.    x = x + 1: LOCATE x, y: PRINT "implementation of some of the routines, and not"
  1300.    x = x + 1: LOCATE x, y: PRINT "a complete tutorial on using GIZLIB.  All the"
  1301.    x = x + 1: LOCATE x, y: PRINT "routines available are not even demonstrated! "
  1302.    x = x + 2: LOCATE x, y: PRINT "Refer to the documentation for complete details on"
  1303.    x = x + 1: LOCATE x, y: PRINT "usage and implementation."
  1304.  
  1305.  
  1306. extt:
  1307.    SYSTEM
  1308.  
  1309.  
  1310. '---------------------[subroutines]-----------------
  1311. '    This next step is very important.  As a matter of course,
  1312. '  BASIC will shift an array's location in memory.  To make
  1313. '  sure that your screen array pointers are indeed pointing
  1314. '  to the right spot, do a GOSUB to set them before CALLing
  1315. '  any routine that depends on the segment and offset of a
  1316. '  screen array.
  1317.  
  1318. set.pointers:
  1319.     segmt1 = VARSEG(sarry(1)): sptr1 = VARPTR(sarry(1))
  1320.     segmt2 = VARSEG(sarry(2001)): sptr2 = VARPTR(sarry(2001))
  1321.     segmt3 = VARSEG(sarry(4001)): sptr3 = VARPTR(sarry(4001))
  1322.     segmt4 = VARSEG(sarry(6001)): sptr4 = VARPTR(sarry(6001))
  1323.     segmt5 = VARSEG(sarry(8001)): sptr5 = VARPTR(sarry(8001))
  1324.     segmt6 = VARSEG(sarry(10001)): sptr6 = VARPTR(sarry(10001))
  1325.     segmt7 = VARSEG(sarry(12001)): sptr7 = VARPTR(sarry(12001))
  1326.  
  1327. RETURN
  1328.  
  1329.  
  1330.  
  1331. title:                '********************
  1332.    COLOR fgt, 0
  1333.    LOCATE 2, 25: PRINT "GIZLIB 1.4 Demo of QB Routines. "
  1334.    COLOR fgs, bgs
  1335. RETURN
  1336.  
  1337.  
  1338. wait.key:  '***********************
  1339.    LOCATE 24, 25
  1340.    COLOR 14, 0: PRINT "Press any key to continue.";
  1341.  
  1342. waitk2:
  1343.    cont$ = INKEY$
  1344.    WHILE cont$ = ""
  1345.        cont$ = INKEY$
  1346.    WEND
  1347.    LOCATE 23, 25: PRINT SPACE$(50);
  1348.    COLOR fg, bg
  1349. RETURN
  1350.  
  1351.  
  1352. get.string:
  1353.    COLOR fgt, 0: LOCATE lin, 1: PRINT "=> "; : COLOR fgs, 0
  1354.    ky$ = "": text$ = ""
  1355.    ky$ = INKEY$
  1356.    DO UNTIL ky$ = CHR$(13) OR LEN(text$) >= max      'this is new to QB 3.0
  1357.         ky$ = INKEY$
  1358.         IF ky$ >= CHR$(32) THEN
  1359.         PRINT ky$;
  1360.         text$ = text$ + ky$
  1361.         ELSEIF ky$ = CHR$(8) AND LEN(text$) >= 1 THEN
  1362.         PRINT CHR$(29) + CHR$(32) + CHR$(29);
  1363.         text$ = LEFT$(text$, LEN(text$) - 1)
  1364.         END IF
  1365.    LOOP
  1366.    IF text$ = CHR$(13) THEN GOTO get.string
  1367. RETURN
  1368.  
  1369. '  unREM the following lines with a text editor for QB4
  1370. '
  1371. SUB DIR (mask$, fil$()) STATIC
  1372.  
  1373.     REM $INCLUDE: 'DIR.SUB'               ' This provides an interface similar
  1374.  
  1375. END SUB
  1376.  
  1377.