home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / menu / progen / source / prolib71.bas < prev    next >
Encoding:
BASIC Source File  |  1991-10-08  |  63.8 KB  |  2,449 lines
  1. DECLARE FUNCTION strval$ (a%)
  2. DEFINT A-Z
  3.    '============================================================================
  4.    '  PURPOSE: These are the general purpose routines needed by the other
  5.    '           modules in the user interface .
  6.    '
  7.    '  To create a library and QuickLib containing all routines from
  8.    '  the User Interface follow these steps:
  9.    '       ed PROLIB71  'load PROLIB71 + /L PROASM71.QLB
  10.    '       load PROLIB71 into QBX and make lib
  11.    '============================================================================
  12.  
  13. '$INCLUDE: 'qbx.bi'
  14. '$INCLUDE: 'prolib71.bi'
  15.  
  16. '
  17.    ' msg$(1) = "Yes, go ahead"
  18.    ' msg$(2) = "No, I don't want to "
  19.    '
  20.    ' Ques$ = "(Y/N)" or any prompt
  21.    ' answ$ = "YyNn"  accept only (yn)
  22.    '
  23.    ' AskQuestion msg$(), 2, 1,DispPos, black, white, black, white, Ques$, answ$
  24.    '
  25.    ' IF answ$ = "Y" THEN
  26.    '
  27.    '
  28.    SUB AskQuestion (mop$(), numlines, Border, DispPos, FrmFG, FrmBG, GenFG, GenBG, Ques$, ans$)
  29.       check$ = ans$
  30.       maxwidth = LEN(Ques$)
  31.       FOR j = 1 TO numlines
  32.      Trim mop$(j)
  33.      maxwidth = Maximum(maxwidth, LEN(mop$(j)))
  34.       NEXT j
  35.       maxwidth = maxwidth + 4
  36.       maxheight = numlines + 4
  37.       maxheight = maxheight + 2
  38.  
  39.       IF maxwidth > 80 THEN
  40.      EXIT SUB
  41.       END IF
  42.  
  43.       IF maxheight > 24 THEN
  44.      EXIT SUB
  45.       END IF
  46.  
  47.       LeftCol = 80 - maxwidth
  48.       LeftCol = LeftCol / 2
  49.  
  50.       SELECT CASE DispPos
  51.      CASE 0
  52.         TopRow = 1
  53.      CASE 1
  54.         TopRow = (24 - maxheight)
  55.         TopRow = TopRow / 2
  56.      CASE 2
  57.         TopRow = (24 - maxheight)
  58.      CASE ELSE
  59.         EXIT SUB
  60.       END SELECT
  61.  
  62.       CALL GetBackground(TopRow, LeftCol, TopRow + maxheight + 1, LeftCol + maxwidth + 1, aqbuf$)
  63.       CALL DrawBox(TopRow, LeftCol, maxwidth, maxheight, Border, FrmFG, FrmBG, 1, GenFG, GenBG, 1)
  64.  
  65.       FOR j = 1 TO numlines
  66.      Diff = (maxwidth - LEN(mop$(j)))
  67.      IF Diff THEN
  68.         Diff = Diff / 2
  69.      END IF
  70.      TextToPrint$ = mop$(j)
  71.      ROW = j + TopRow + 1
  72.      col = LeftCol + Diff
  73.      CALL pnc(TextToPrint$, ROW, col, GenFG, GenBG)
  74.       NEXT j
  75.  
  76.       ROW = TopRow + numlines + 3
  77.       Diff = (maxwidth - LEN(Ques$))
  78.  
  79.       IF Diff THEN
  80.      Diff = Diff / 2
  81.       END IF
  82.  
  83.       col = LeftCol + Diff
  84.       CALL pnc(Ques$, ROW, col, GenBG, GenFG)
  85.  
  86.       DO
  87.      ans$ = ""
  88.      WHILE ans$ = ""
  89.         ans$ = UCASE$(INKEY$)
  90.      WEND
  91.       LOOP WHILE INSTR(check$, ans$) = 0
  92.  
  93.       CALL PutBackground(TopRow, LeftCol, aqbuf$): aqbuf$ = ""
  94.    END SUB
  95.  
  96.    SUB CapsOff STATIC
  97.       DEF SEG = 0
  98.       POKE &H417, PEEK(&H417) AND &HBF
  99.       DEF SEG
  100.    END SUB
  101.  
  102.    SUB CapsOn STATIC
  103.       DEF SEG = 0
  104.       POKE &H417, PEEK(&H417) OR &H40
  105.       DEF SEG
  106.    END SUB
  107.  
  108.    ' center text on printer
  109.    ' PW = printer with to center text
  110.    '
  111.    SUB CenterPrn (text$, PW%) STATIC
  112.       a% = PW% - LEN(RTRIM$(text$))
  113.       a% = a% / 2
  114.       LPRINT TAB(a%); text$
  115.    END SUB
  116.  
  117. REM $DYNAMIC
  118.    SUB CenterText (mop$, ROW, fg, bg) STATIC
  119.       c = 80 - LEN(mop$)
  120.       c = c / 2
  121.       pnc mop$, ROW, c, fg, bg
  122.    END SUB
  123.  
  124. REM $STATIC
  125. '
  126.    FUNCTION CheckFunction (ch)
  127.       IF ch > 58 AND ch < 69 THEN
  128.      CheckFunction = ch - 58
  129.       END IF
  130.       IF ch > 83 AND ch < 114 THEN
  131.      CheckFunction = ch - 73
  132.       END IF
  133.    END FUNCTION
  134.  
  135. REM $DYNAMIC
  136.    FUNCTION CheckPrinter%
  137.       ' returns zero if printer not ready
  138.       DIM printer$(2)
  139.       DEF SEG = &H40
  140.       prtrbase% = PEEK(9) * 256 + PEEK(8) + 1
  141.  
  142.       pcode% = INP(prtrbase%)
  143.  
  144.       DEF SEG
  145.  
  146.       SELECT CASE pcode%
  147.  
  148.       CASE 71
  149.      printer$(1) = "Printer Off Line"
  150.      CheckPrinter% = 0
  151.       CASE 87
  152.      printer$(1) = "Printer Off Line"
  153.      CheckPrinter% = 0
  154.  
  155.       CASE 119
  156.      printer$(1) = "Printer Out of Paper"
  157.      CheckPrinter% = 0
  158.       CASE 127
  159.      printer$(1) = "Printer Not Connected"
  160.      CheckPrinter% = 0
  161.       CASE 135
  162.      printer$(1) = "Printer Turned Off"
  163.      CheckPrinter% = 0
  164.       CASE 191
  165.      printer$(1) = "Printer Not Connected"
  166.      CheckPrinter% = 0
  167.  
  168.       CASE 223
  169.      CheckPrinter% = 1
  170.      EXIT FUNCTION
  171.       CASE 247
  172.      printer$(1) = "Printer Turned Off"
  173.      CheckPrinter% = 0
  174.  
  175.       CASE ELSE
  176.      CheckPrinter% = pcode%
  177.  
  178.      printer$(1) = "Printer Code: " + STR$(pcode%)
  179.      printer$(2) = "Correct and Press anykey"
  180.  
  181.       Message printer$(), 2, 2, BLACK, WHITE, BLACK, WHITE
  182.  
  183.       END SELECT
  184.      printer$(2) = "Correct and Press anykey"
  185.  
  186.       Message printer$(), 2, 2, BLACK, WHITE, BLACK, WHITE
  187.  
  188.    END FUNCTION
  189.  
  190. REM $STATIC
  191. '
  192.    SUB DialogBox (Ques$(), Before, After, LENGTH, FrmFG, FrmBG, GenFG, GenBG, DispPos, Answer$, format$, Ek)
  193.  
  194.       boxheight = Before + After
  195.       height = boxheight
  196.       height = height + 5
  197.  
  198.       IF height > 25 THEN
  199.      EXIT SUB
  200.       END IF
  201.  
  202.       IF LENGTH < 1 THEN
  203.      EXIT SUB
  204.       END IF
  205.  
  206.       SELECT CASE DispPos
  207.      CASE 0
  208.         begin = 1
  209.      shadow = 1
  210.      CASE 1
  211.         begin = (25 - height) / 2
  212.      shadow = 1
  213.      CASE 2
  214.         begin = (25 - height) + 1
  215.      shadow = 0
  216.      CASE ELSE
  217.         EXIT SUB
  218.       END SELECT
  219.       textwidth = LENGTH
  220.  
  221.       FOR j = 1 TO boxheight
  222.      Trim Ques$(j)
  223.      IF LEN(Ques$(j)) > textwidth THEN
  224.         textwidth = LEN(Ques$(j))
  225.      END IF
  226.       NEXT j
  227.       BoxWidth = textwidth + 4
  228.       LeftCol = (80 - BoxWidth) / 2
  229.       Wid = BoxWidth
  230.       FrameType = 1
  231.       Fill = 1
  232.  
  233.       GetBackground begin, LeftCol, begin + height + 2, LeftCol + Wid + 2, dbbuf$
  234.       DrawBox begin, LeftCol, Wid, height, FrameType, FrmFG, FrmBG, Fill, GenFG, GenBG, shadow
  235.  
  236.       FOR j = 1 TO Before
  237.      mop$ = Ques$(j)
  238.      Trim mop$
  239.      c = Wid - LEN(mop$)
  240.      c = c / 2
  241.      pnc mop$, begin + j, LeftCol + c, GenFG, GenBG
  242.       NEXT j
  243.       FOR j = 1 TO After
  244.      mop$ = Ques$(j + Before)
  245.      Trim mop$
  246.      c = Wid - LEN(mop$)
  247.      c = c / 2
  248.      pnc mop$, begin + Before + 3 + j, LeftCol + c, GenFG, GenBG
  249.       NEXT j
  250.  
  251.       Istart = (80 - LENGTH) / 2
  252.       DrawBox begin + Before + 1, Istart - 1, LENGTH + 2, 3, 1, FrmFG, FrmBG, 0, GenFG, GenBG, 0
  253.       xc = LeftCol + 2
  254.       yc = begin + Before + 2
  255.       LOCATE yc, Istart
  256.  
  257.       IF format$ = "" THEN
  258.      format$ = STRING$(LENGTH, "#")
  259.      Answer$ = FES(0, GenFG, GenBG, Answer$, format$, 1, Ek, 0, 0, 0, 0, 1, 1, 1, 0)
  260.       ELSEIF INSTR(format$, ".") THEN
  261.      Answer$ = FEN(0, GenFG, GenBG, Answer$, format$, Ek, 0, 0, 0, 0, 1, 1, 1)
  262.       ELSE
  263.      Answer$ = FES(0, GenFG, GenBG, Answer$, format$, 1, Ek, 0, 0, 0, 0, 1, 1, 1, 0)
  264.       END IF
  265.  
  266.       PutBackground begin, LeftCol, dbbuf$: dbbuf$ = ""
  267.    END SUB
  268.  
  269. SUB dialogtwo (dialog$(), first$, lenfirst, second$, lensecond) STATIC
  270.  
  271.         d% = lenfirst
  272.         IF d% > lensecond THEN
  273.             d% = lensecond
  274.         END IF
  275.         FOR j% = 1 TO 4
  276.             k% = LEN(dialog$(j%))
  277.             IF k% > d% THEN d% = k%
  278.         NEXT j%
  279.         w% = d% + 6
  280.  
  281.         lmarg% = (80 - w%) / 2
  282.         tmarg% = 7
  283.         rmarg% = lmarg% + w% - 1
  284.         bmarg% = 18
  285.         
  286.         CALL GetBackground(tmarg%, lmarg%, bmarg%, rmarg%, dl2$)
  287.         CALL drawwind(tmarg%, lmarg%, bmarg%, rmarg%, 1, 1)
  288.         CALL Colorwind(tmarg%, lmarg%, bmarg%, rmarg%, 32, 1, BLACK, WHITE)
  289.  
  290.         lmarg% = lmarg% + 4
  291.  
  292.         CALL pnc(dialog$(1), tmarg% + 1, lmarg%, BLACK, WHITE)
  293.         CALL pnc(dialog$(2), tmarg% + 5, lmarg%, BLACK, WHITE)
  294.         CALL pnc(dialog$(3), tmarg% + 9, lmarg%, BLACK, WHITE)
  295.         CALL pnc(dialog$(4), tmarg% + 10, lmarg%, BLACK, WHITE)
  296.  
  297.         ipy1% = tmarg% + 2
  298.         ipy2% = tmarg% + 6
  299.  
  300.         IF lenfirst THEN
  301.             CALL drawwind(ipy1%, lmarg%, ipy1% + 2, lenfirst + lmarg% + 1, 1, 0)
  302.         END IF
  303.  
  304.         IF lensecond THEN
  305.             CALL drawwind(ipy2%, lmarg%, ipy2% + 2, lensecond + lmarg% + 1, 1, 0)
  306.             
  307.         END IF
  308.  
  309.         IF lenfirst THEN
  310.         LOCATE ipy1% + 1, lmarg% + 1
  311.         format$ = STRING$(lenfirst, "#")
  312.         first$ = FES(0, BLACK, WHITE, second$, format$, 0, Ek%, 0, 0, 0, 0, 1, 1, 1, 0)
  313.  
  314.         END IF
  315.  
  316.         IF lensecond THEN
  317.          LOCATE ipy2% + 1, lmarg% + 1
  318.          format$ = STRING$(lensecond, "#")
  319.          second$ = FES(0, BLACK, WHITE, second$, format$, 0, Ek%, 0, 0, 0, 0, 1, 1, 1, 0)
  320.  
  321.         END IF
  322.  
  323.         CALL PutBackground(tmarg%, lmarg% - 4, dl2$): dl2$ = ""
  324.         LOCATE , , 0
  325.  
  326.         END SUB
  327.  
  328. REM $DYNAMIC
  329. '
  330.    SUB DoMoney (amount@, alpha1$, alpha2$)
  331.  
  332.       money$ = ""
  333.  
  334.       amount$ = userNformat$(STR$(amount@), "999999.99")
  335.       ones$ = "     ONE  TWO  THREEFOUR FIVE SIX  SEVENEIGHTNINE "
  336.       teen$ = "TEN      ELEVEN   TWELVE    THIRTEENFOURTEEN FIFTEEN   SIXTEEN SEVENTEENEIGHTEEN NINETEEN "
  337.       tens$ = "TWENTY THIRTY FORTY  FIFTY  SIXTY  SEVENTYEIGHTY NINETY"
  338.  
  339.       'hundreds of thousands
  340.  
  341.       IF LEFT$(amount$, 1) > " " THEN
  342.      money$ = RTRIM$(MID$(ones$, VAL(LEFT$(amount$, 1)) * 5 + 1, 5)) + " HUNDRED "
  343.       END IF
  344.  
  345.       ' tens of thousands
  346.  
  347.       IF MID$(amount$, 2, 1) > "1" THEN
  348.      money$ = money$ + RTRIM$(MID$(tens$, VAL(MID$(amount$, 2, 1)) * 7 - 13, 7))
  349.      IF MID$(amount$, 3, 1) > "0" THEN
  350.         money$ = money$ + "-" + RTRIM$(MID$(ones$, VAL(MID$(amount$, 3, 1)) * 5 + 1, 5))
  351.      END IF
  352.      money$ = money$ + " THOUSAND "
  353.       ELSEIF MID$(amount$, 2, 1) = "1" THEN
  354.      money$ = money$ + RTRIM$(MID$(teen$, VAL(MID$(amount$, 3, 1)) * 9 + 1, 9)) + " THOUSAND "
  355.       ELSEIF MID$(amount$, 2, 2) = "00" THEN
  356.      money$ = money$ + "THOUSAND "
  357.       ELSEIF MID$(amount$, 3, 1) > " " THEN
  358.      money$ = money$ + RTRIM$(MID$(ones$, VAL(MID$(amount$, 3, 1)) * 5 + 1, 5)) + " THOUSAND "
  359.       END IF
  360.  
  361.       ' hundreds
  362.  
  363.       IF MID$(amount$, 4, 1) > "0" THEN
  364.      money$ = money$ + RTRIM$(MID$(ones$, VAL(MID$(amount$, 4, 1)) * 5 + 1, 5)) + " HUNDRED "
  365.       END IF
  366.  
  367.       ' tens and ones
  368.  
  369.       IF MID$(amount$, 5, 1) > "1" THEN
  370.      money$ = money$ + RTRIM$(MID$(tens$, VAL(MID$(amount$, 5, 1)) * 7 - 13, 7))
  371.      IF MID$(amount$, 6, 1) > "0" THEN
  372.         money$ = money$ + "-" + RTRIM$(MID$(ones$, VAL(MID$(amount$, 6, 1)) * 5 + 1, 5))
  373.      END IF
  374.       ELSEIF MID$(amount$, 5, 1) = "1" THEN
  375.      money$ = money$ + RTRIM$(MID$(teen$, VAL(MID$(amount$, 6, 1)) * 9 + 1, 9))
  376.       ELSE
  377.      IF VAL(MID$(amount$, 1, 6)) = 0 THEN
  378.         money$ = "ZERO"
  379.      END IF
  380.      money$ = money$ + RTRIM$(MID$(ones$, VAL(MID$(amount$, 6, 1)) * 5 + 1, 5))
  381.       END IF
  382.  
  383.       'do decimal places
  384.  
  385.       cents$ = RIGHT$(amount$, 2)
  386.       money$ = RTRIM$(money$) + " AND " + cents$ + "/100"  ' DOLLARS"
  387.       LENGTH = LEN(money$)
  388.  
  389.       ' if length is greater than 75, the words will have to be
  390.       '    split so that it will fit on the check
  391.  
  392.       IF LENGTH > 75 THEN
  393.      counter = 74
  394.      DO WHILE INSTR(counter, money$, " - ")
  395.         counter = counter - 1
  396.      LOOP
  397.      '  divide the string into two parts
  398.      alpha1$ = LEFT$(money$, counter)  ' + LEFT$(STOREAGE$, 75 - counter)
  399.      alpha2$ = MID$(money$, counter + 1, LENGTH - counter)
  400.      Trim alpha1$
  401.      Trim alpha2$
  402.       ELSE
  403.      '  word is less than or equal to 75 characters
  404.      alpha1$ = money$
  405.      Trim alpha1$
  406.       END IF
  407.    END SUB
  408.  
  409. REM $STATIC
  410.    SUB DrawBox (TopRow, LeftCol, Wid, height, FrameType, FrmFgd, FrmBgd, Fill, FillFgd, FillBgd, shadow) STATIC
  411.       IF Wid < 2 THEN
  412.      EXIT SUB
  413.       END IF
  414.       IF height < 2 THEN
  415.      EXIT SUB
  416.       END IF
  417.       botrow = TopRow + height - 1
  418.       rightcol = LeftCol + Wid - 1
  419.       'draw frame
  420.       CALL drawwind(TopRow, LeftCol, botrow, rightcol, FrameType, 0)
  421.       'color frame
  422.       CALL Colorwind(TopRow, LeftCol, botrow, rightcol, 0, 1, FrmFgd, FrmBgd)
  423.       IF shadow THEN
  424.      ' do RIGHTK shadow
  425.      CALL Colorwind(TopRow + 1, LeftCol + Wid, botrow + 1, LeftCol + Wid + 1, 0, 1, 7, 0)
  426.      ' do bottom shadow
  427.      CALL Colorwind(botrow + 1, LeftCol + 1, botrow + 1, LeftCol + Wid + 1, 0, 1, 7, 0)
  428.       END IF
  429.       SELECT CASE Fill
  430.      CASE 1
  431.         body$ = " "
  432.      CASE 2
  433.         body$ = "▓"
  434.      CASE 3
  435.         body$ = "█"
  436.      CASE 4
  437.         body$ = "░"
  438.      CASE 5
  439.         body$ = "▒"
  440.      CASE ELSE
  441.         body$ = " "
  442.       END SELECT
  443.  
  444.       IF Fill <> 0 THEN
  445.      CALL Colorwind(TopRow + 1, LeftCol + 1, botrow - 1, LeftCol + Wid - 2, ASC(body$), 0, FillFgd, FillBgd)
  446.       END IF
  447.  
  448.    END SUB
  449.  
  450. REM $DYNAMIC
  451. SUB DspEquipment
  452. romdate$ = "00/00/00"
  453.  
  454. DIM disp$(15)
  455.  
  456.     CALL GetRomDate(romdate$)
  457.     CALL GetRam(ram%, EXTram%, EXPram%)
  458.     printers% = GetNumLPT
  459.     rs232% = GetNumCom
  460.     floppies% = GetNumFlop
  461.     gameport% = GetNumGames
  462.     disks% = GetNumHard
  463.  
  464.     SELECT CASE VIDEOcheck
  465.         CASE 1
  466.         vid$ = "MDA"
  467.         CASE 2
  468.         vid$ = "HCG"
  469.         CASE 3
  470.         vid$ = "CGA"
  471.         CASE 4
  472.         vid$ = "EGA"
  473.         CASE 5
  474.         vid$ = "VGA Color"
  475.         CASE 6
  476.         vid$ = "VGA Mono"
  477.         CASE 7
  478.         vid$ = "MODEL 30 Mono"
  479.         CASE 8
  480.         vid$ = "MODEL 30 Color"
  481.         CASE ELSE
  482.         vid$ = "UnKnown"
  483.     END SELECT
  484.  
  485.   SELECT CASE CPUcheck
  486.      CASE 1
  487.      cpu$ = "8086/88"
  488.      CASE 2
  489.      cpu$ = "80286"
  490.      CASE 3
  491.      cpu$ = "386/486"
  492.      CASE ELSE
  493.      cpu$ = "UnKnown"
  494.   END SELECT
  495.            disp$(1) = "CPU type.................: " + cpu$
  496.            disp$(2) = "Video type...............: " + vid$
  497.            disp$(3) = "Rom Bios Date............: " + romdate$
  498.            disp$(4) = "Amount of DOS RAM........: " + userNformat$(STR$(ram%), "9999999") + "K"
  499.            disp$(5) = "Amount of EXT RAM........: " + userNformat$(STR$(EXTram%), "9999999") + "K"
  500.            disp$(6) = "Amount of EXP RAM........: " + userNformat$(STR$(EXPram% * 16), "9999999") + "K"
  501.            disp$(7) = "Number of Printer Ports..: " + userNformat$(STR$(printers%), "9999999")
  502.            disp$(8) = "Number of RS232..........: " + userNformat$(STR$(rs232%), "9999999")
  503.            disp$(9) = "Number of Floppies.......: " + userNformat$(STR$(floppies%), "9999999")
  504.           disp$(10) = "Number of Hard drives....: " + userNformat$(STR$(disks%), "9999999")
  505.           disp$(11) = "Number of Game ports.....: " + userNformat$(STR$(gameport%), "9999999")
  506.           disp$(12) = ""
  507.           disp$(13) = "Press any key to continue"
  508.  
  509.            lines = 13
  510.            Border = 2
  511.  
  512.           FrmFG = BLACK
  513.           FrmBG = WHITE
  514.           GenFG = BLACK
  515.           GenBG = WHITE
  516.           maxwidth = 0
  517.  
  518.       El = UBOUND(disp$, 1)
  519.  
  520.       IF lines > El THEN
  521.      EXIT SUB
  522.       END IF
  523.       FOR j = 1 TO lines
  524.      Trim disp$(j)
  525.      maxwidth = Maximum(maxwidth, LEN(disp$(j)))
  526.       NEXT j
  527.       maxwidth = maxwidth + 5
  528.       maxheight = lines + 4
  529.  
  530.       IF maxwidth > 80 THEN
  531.      EXIT SUB
  532.       END IF
  533.  
  534.       IF maxheight > 24 THEN
  535.      EXIT SUB
  536.       END IF
  537.  
  538.       TopRow = 24 - maxheight
  539.       TopRow = TopRow / 2
  540.       LeftCol = 80 - maxwidth
  541.       LeftCol = LeftCol / 2
  542.  
  543.       GetBackground TopRow, LeftCol, TopRow + maxheight + 1, LeftCol + maxwidth + 1, msbuf$
  544.       DrawBox TopRow, LeftCol, maxwidth, maxheight, Border, FrmFG, FrmBG, 1, GenFG, GenBG, 1
  545.  
  546.       FOR j = 1 TO lines
  547.      Diff = (maxwidth - LEN(disp$(j)))
  548.      IF Diff THEN
  549.         Diff = Diff / 2
  550.      END IF
  551.      TextToPrint$ = disp$(j)
  552.      ROW = j + TopRow + 1
  553.      col = LeftCol + 2'+ Diff
  554.      pnc TextToPrint$, ROW, col, GenFG, GenBG
  555.       NEXT j
  556.       DO
  557.      key$ = INKEY$
  558.       LOOP UNTIL key$ <> ""
  559.       PutBackground TopRow, LeftCol, msbuf$: msbuf$ = ""
  560.  
  561.  
  562. END SUB
  563.  
  564. REM $STATIC
  565. '
  566. 'DATE: 05/30/90
  567. 'DATE: 10/03/91
  568. '           numeric formats allow higest
  569. '           value of format position.
  570. '
  571. '      format$ = "99999.99" decimal   ( any decimal position)
  572. '      format$ = "99" numbers only  < (99 max) each digit = to max value
  573. '      format$ = "19" (19) is max value
  574. '
  575. '      use basic print using "####.##";VAL(instring$) for decimal numbers
  576. '      or integer.            decimal  pos and length optional
  577. '
  578. '       USE LOCATE ROW,COLUMN
  579. '
  580. '       maybe passed by parameters if you like to add to parms
  581. '
  582. '       column = Column pos to start printing
  583. '       Row = Row to start printing
  584. '
  585. '       set editforeground color  before call
  586. '       set editbackgroung color  before call
  587. '
  588. '       ExitCode = VALUE EXIT  1 TO 7
  589. '
  590. '       set flags to enable  to exit on key
  591. '
  592. '       UPflag     = True  ,exitcode =  1
  593. '       PGUPflag   = True  ,exitcode =  2
  594. '       DNflag     = True  ,exitcode =  3
  595. '       PGDNflag   = True  ,exitcode =  4
  596. '       RETflag    = True  ,exitcode =  5
  597. '       TABflag    = True  ,exitcode =  6
  598. '       ESCflag    = True  ,exitcode =  7
  599. '
  600. '       ESC key restores field if True or False
  601. '
  602. '   sample how to handle exitcode after input routine (see program).
  603. '
  604. '   SELECT CASE ExitCode%
  605. '
  606. '       CASE 1 'what to do if uparrow key exit
  607. '               could be
  608. '               GOTO previous entry
  609. '
  610. '       CASE 2 'what to do if pageup key exit
  611. '
  612. '       CASE 3 'what to do if downarrow key exit
  613. '               could be
  614. '               GOTO next entry
  615. '       CASE 4 'what to do if pagedown key exit
  616. '
  617. '       CASE 5 'what to do if enter key exit
  618. '                could be accept entry
  619. '       CASE 6 'what to do if tab key exit
  620. '               'could be return to menu
  621. '
  622. '   END SELECT
  623. '
  624.   FUNCTION FEN$ (SB, EFG, EBG, work$, format$, Exitcode, UPflag, PGUPflag, DNflag, PGDNflag, RETflag, TABflag, escflag)
  625.  
  626.  
  627.       STATIC curpos
  628.       ROW = CSRLIN
  629.       col = POS(0)
  630.       DIM Hlp$(9)
  631.       firsttime = 1
  632.       LENGTH = LEN(format$)
  633.       IF SB = TRUE THEN
  634.       GetBackground ROW, col, ROW, col + LENGTH, ed$
  635.       END IF
  636.  
  637.       SELECT CASE LEN(work$)
  638.      CASE IS > LENGTH
  639.         work$ = RIGHT$(work$, LENGTH)
  640.      CASE IS < LENGTH
  641.         work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  642.       END SELECT
  643.  
  644.       IF INSTR(format$, ".") THEN
  645.      decflag = 1
  646.      IF INSTR(work$, ".") THEN
  647.         FormatDEC (work$), bforeDEC, aftDEC
  648.         FormatDEC (format$), beforeDEC, afterdec
  649.         work$ = RemoveCHAR$((work$), ".")
  650.         IF afterdec > aftDEC THEN
  651.            work$ = work$ + STRING$(afterdec - (aftDEC - 1), "0")
  652.         END IF
  653.         IF afterdec < aftDEC THEN
  654.            work$ = STRING$(aftDEC - (afterdec - 1), " ") + LEFT$(work$, beforeDEC + (afterdec - 1))
  655.         END IF
  656.      ELSE
  657.         FormatDEC format$, beforeDEC, afterdec
  658.         work$ = work$ + STRING$(afterdec + 1, "0")
  659.      END IF
  660.       ELSE
  661.      FormatDEC (work$), beforeDEC, afterdec
  662.      work$ = LEFT$(work$, beforeDEC)
  663.      afterdec = 0
  664.      work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  665.      decflag = 0
  666.       END IF
  667.       SELECT CASE LEN(work$)
  668.      CASE IS > LENGTH
  669.         work$ = RIGHT$(work$, LENGTH)
  670.      CASE IS < LENGTH
  671.         IF decflag THEN
  672.            work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  673.         ELSE
  674.            work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  675.         END IF
  676.       END SELECT
  677.       temp$ = work$
  678.       work$ = STRING$(LENGTH, " ")
  679.       k = 1
  680.       FOR j = 1 TO LENGTH
  681.      Character$ = MID$(format$, j, 1)
  682.      IF INSTR(".", Character$) THEN
  683.         MID$(work$, j, 1) = Character$
  684.      ELSE
  685.         char$ = MID$(temp$, k, 1)
  686.         MID$(work$, j, 1) = char$
  687.         k = k + 1
  688.      END IF
  689.       NEXT j
  690.       org$ = work$
  691.       curpos = 1
  692.       Exitcode = 0
  693.       'COLOR efg, ebg
  694.       LOCATE ROW, col
  695.       'PRINT work$;
  696.       pnc work$, ROW, col, EFG, EBG
  697.  
  698.       DO
  699.      SELECT CASE curpos
  700.         CASE IS > LENGTH
  701.            curpos = LENGTH
  702.         CASE IS < 1
  703.            curpos = 1
  704.      END SELECT
  705.      LOCATE ROW, col
  706.      'PRINT work$;
  707.       pnc work$, ROW, col, EFG, EBG
  708.  
  709.      LOCATE ROW, col + LENGTH - 1, 1, 7, 7
  710.      Choice$ = ""
  711.      WHILE Choice$ = ""
  712.         Choice$ = INKEY$
  713.      WEND
  714.      LOCATE , , 0
  715.      IF LEN(Choice$) = 1 THEN
  716.         special$ = MID$(format$, curpos, 1)
  717.         keychoice = ASC(Choice$)
  718.         SELECT CASE keychoice
  719.            CASE ENTER
  720.           IF RETflag = TRUE THEN
  721.              Exitcode = 5
  722.              EXIT DO
  723.           END IF
  724.            CASE TABKEY
  725.           IF TABflag = TRUE THEN
  726.              Exitcode = 6
  727.              EXIT DO
  728.           END IF
  729.            CASE ESC
  730.           work$ = org$
  731.           curpos = 1
  732.           IF escflag = TRUE THEN
  733.              Exitcode = 7
  734.              EXIT DO
  735.           END IF
  736.            CASE CTRLE
  737.           work$ = ""
  738.           IF LEN(work$) = 0 THEN
  739.              IF afterdec > 0 THEN
  740.             work$ = STRING$(afterdec, "0")
  741.             IF LEN(work$) < LENGTH THEN
  742.                IF decflag THEN
  743.                   work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  744.                ELSE
  745.                   work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  746.                END IF
  747.                work$ = userSformat$(work$, format$)
  748.             END IF
  749.              ELSE
  750.             work$ = ""
  751.             IF LEN(work$) < LENGTH THEN
  752.                IF decflag THEN
  753.                   work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  754.                ELSE
  755.                   work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  756.                END IF
  757.                work$ = userSformat$(work$, format$)
  758.             END IF
  759.              END IF
  760.           END IF
  761.         END SELECT
  762.         SELECT CASE special$
  763.            CASE "0" TO "9"
  764.           IF Choice$ <= special$ THEN
  765.              keychoice = ASC(Choice$)
  766.           ELSE
  767.              keychoice = 0
  768.           END IF
  769.         END SELECT
  770.         SELECT CASE Choice$
  771.            CASE "-"
  772.           temp$ = work$
  773.           work$ = ""
  774.           IF LEN(work$) = 0 THEN
  775.              IF afterdec > 0 THEN
  776.             work$ = LTRIM$(RTRIM$(Choice$)) + STRING$(afterdec, "0")
  777.             IF LEN(work$) < LENGTH THEN
  778.                IF decflag THEN
  779.                   work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  780.                ELSE
  781.                   work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  782.                END IF
  783.                work$ = userSformat$(work$, format$)
  784.             END IF
  785.              ELSE
  786.             work$ = LTRIM$(RTRIM$(Choice$))
  787.             IF LEN(work$) < LENGTH THEN
  788.                IF decflag THEN
  789.                   work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  790.                ELSE
  791.                   work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  792.                END IF
  793.                work$ = userSformat$(work$, format$)
  794.             END IF
  795.              END IF
  796.           END IF
  797.         END SELECT
  798.         SELECT CASE CHR$(keychoice)
  799.            CASE "0" TO "9"
  800.           FOR j = 1 TO LENGTH
  801.              Character$ = MID$(format$, j, 1)
  802.              IF INSTR(".", Character$) THEN
  803.             MID$(work$, j, 1) = CHR$(255)
  804.             cursor = cursor + 1
  805.              END IF
  806.           NEXT j
  807.           work$ = RemoveCHAR$(work$, CHR$(255))
  808.           IF firsttime = 1 THEN
  809.              work$ = STRING$(afterdec, "0") + LTRIM$(RTRIM$(Choice$))
  810.              firsttime = 0
  811.           ELSE
  812.              work$ = LTRIM$(RTRIM$(work$)) + LTRIM$(RTRIM$(Choice$))
  813.           END IF
  814.           IF afterdec > 0 THEN
  815.              IF LEN(work$) >= afterdec THEN
  816.             IF LEFT$(work$, 1) = "0" THEN
  817.                work$ = RIGHT$(work$, LEN(work$) - 1)
  818.             END IF
  819.              END IF
  820.           END IF
  821.           IF afterdec > 0 THEN
  822.              IF MID$(work$, 1, 1) = "-" THEN
  823.             IF LEN(work$) > afterdec + 1 THEN
  824.                IF MID$(work$, 2, 1) = "0" THEN
  825.                   work$ = "-" + RIGHT$(work$, LEN(work$) - 2)
  826.                END IF
  827.             END IF
  828.              END IF
  829.           END IF
  830.           IF LEN(work$) < LENGTH THEN
  831.              IF decflag THEN
  832.             work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  833.              ELSE
  834.             work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  835.              END IF
  836.           END IF
  837.           work$ = userSformat$(work$, format$)
  838.           curpos = curpos + 1
  839.         END SELECT
  840.      ELSE
  841.         keychoice = ASC(MID$(Choice$, 2))
  842.         SELECT CASE keychoice
  843.            CASE DELETEK
  844.           FOR j = 1 TO LENGTH
  845.              Character$ = MID$(format$, j, 1)
  846.              IF INSTR(".", Character$) THEN
  847.             MID$(work$, j, 1) = CHR$(255)
  848.              ELSE
  849.              END IF
  850.           NEXT j
  851.           work$ = RemoveCHAR$(work$, CHR$(255))
  852.           work$ = LTRIM$(RTRIM$(work$))
  853.           IF afterdec > 0 THEN
  854.              IF LEN(work$) <= afterdec THEN
  855.             work$ = "0" + work$
  856.              END IF
  857.           END IF
  858.           IF LEN(work$) THEN
  859.              work$ = LEFT$(work$, LEN(work$) - 1)
  860.              IF decflag THEN
  861.             work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  862.              ELSE
  863.             work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  864.              END IF
  865.           END IF
  866.           work$ = userSformat$((work$), format$)
  867.           curpos = curpos - 1
  868.            CASE F1
  869.           GetBackground 1, 1, 25, 80, hpbuf$
  870.           Hlp$(1) = "- NUMERIC EDIT HELP -"
  871.           Hlp$(2) = " " + CHR$(255)
  872.           Hlp$(3) = "ESC    - restores edit field.                       " + CHR$(255)
  873.           Hlp$(4) = "ENTER  - accepts entry and exits Edit.              " + CHR$(255)
  874.           Hlp$(5) = "CTRL E - erases edit field.                         " + CHR$(255)
  875.           Hlp$(6) = "DELETE - deletes char under cursor and shifts right." + CHR$(255)
  876.           Hlp$(7) = "ANY non edit key erases field if first time entry.  " + CHR$(255)
  877.           Hlp$(8) = " " + CHR$(255)
  878.           Hlp$(9) = "Press any key to continue"
  879.           Message Hlp$(), 9, 1, WHITE + 8, RED, WHITE + 8, RED
  880.           'COLOR efg, ebg
  881.           PutBackground 1, 1, hpbuf$: hpbuf$ = ""
  882.            CASE UPK
  883.           IF UPflag = TRUE THEN
  884.              Exitcode = 1
  885.              EXIT DO
  886.           END IF
  887.            CASE PGUP
  888.           IF PGUPflag = TRUE THEN
  889.              Exitcode = 2
  890.              EXIT DO
  891.           END IF
  892.            CASE PGDN
  893.           IF PGDNflag = TRUE THEN
  894.              Exitcode = 4
  895.              EXIT DO
  896.           END IF
  897.            CASE DOWNK
  898.           IF DNflag = TRUE THEN
  899.              Exitcode = 3
  900.              EXIT DO
  901.           END IF
  902.            CASE ELSE
  903.         END SELECT
  904.      END IF
  905.      firsttime = 0
  906.       LOOP WHILE Exitcode = 0
  907.       'COLOR ebg, efg
  908.       LOCATE ROW, col, CURSOROFF
  909.       'PRINT work$;
  910.       pnc work$, ROW, col, EBG, EFG
  911.  
  912.       FOR j = 1 TO LENGTH
  913.      Character$ = MID$(format$, j, 1)
  914.      char$ = MID$(work$, j, 1)
  915.      IF INSTR(".", Character$) THEN
  916.      ELSE
  917.         IF char$ = CHR$(255) THEN
  918.         ELSE
  919.            tmp$ = tmp$ + char$
  920.         END IF
  921.      END IF
  922.       NEXT j
  923.       'COLOR ebg, efg
  924.       tmp$ = RTRIM$(LTRIM$(tmp$))
  925.       IF LEN(tmp$) - 1 < afterdec THEN
  926.      IF LEFT$(tmp$, 1) = "-" THEN
  927.         tmp$ = "-" + STRING$(afterdec - LEN(tmp$) + 1, "0") + RIGHT$(tmp$, LEN(tmp$) - 1)
  928.      END IF
  929.       END IF
  930.       IF LEN(tmp$) < 2 THEN
  931.      tmp$ = "0" + tmp$
  932.       END IF
  933.       IF decflag THEN
  934.      rwork$ = RIGHT$(tmp$, afterdec)
  935.      lwork$ = LEFT$(tmp$, LEN(tmp$) - LEN(rwork$))
  936.      work$ = lwork$ + "." + rwork$
  937.       END IF
  938.       FEN$ = LTRIM$(RTRIM$(work$))
  939.  
  940.       IF SB = TRUE THEN
  941.       PutBackground ROW, col, ed$: ed$ = ""
  942.       END IF
  943.  
  944.    END FUNCTION
  945.  
  946. 'DATE: 05/30/90
  947. 'DATE: 07/14/90
  948. 'DATE: 010/03/91
  949. '                     RAYMOND E DIXON
  950. '                     11660 VC JOHNSON RD
  951. '                     Jacksonville, Fl 32218
  952. '                     (904) 765-4048
  953. '
  954. '  IF ANYONE MAKES ANY INPROVEMENTS I WOULD LIKE YOU TO RENAME THIS SUB
  955. '  TO A NEW NAME. AND IF YOU WOULD SEND ME A COPY.
  956. '
  957. '       formated input routine with user format
  958. '
  959. '       assign values before calling routine
  960. '
  961. '       work$ =""  or string to edit
  962. '
  963. '           numeric formats allow higest
  964. '           value of format position.
  965. '
  966. '      format$ = "99" numbers only  < (99 max) each digit = to max value
  967. '      format$ = "19" (19) is max value
  968. '      format$ = "999-99-9999" SS number
  969. '      format$ = "999-9999"       7  digit phone
  970. '      format$ = "(999) 999-9999" 10 digit phone
  971. '      format$ = "19/39/99"  date format
  972. '      format$ = "########" alphanumeric set for 8 characters (maybe more or less)
  973. '      format$ = "@@@@@@@@" alpha only   same as above
  974. '      format$ = "Y/N:*"    force YN answer.
  975. '      format$ = "M/F:|"    force MF answer.
  976. '      format$ = "~"       'force enter key for prompts or other exit key.
  977. '      format$ = may be any format you can create in a basic string
  978. '                even you can include the Prompt if you like.
  979. '
  980. '      format$ = "Test Data: 99" 'this format will print
  981. '                 Test Data: your value passed
  982. '                            in the the length of 2
  983. '                            Seting numbers 1 to 99.
  984. '
  985. '       USE LOCATE ROW,COLUMN
  986. '
  987. '       maybe passed by parameters if you like to add to parms
  988. '
  989. '       column = Column pos to start printing
  990. '       Row = Row to start printing
  991. '
  992. '       set foreground color  before call
  993. '
  994. '       set backgroung color  before call
  995. '
  996. '       ExitCode = VALUE EXIT  1 TO 9
  997. '
  998. '       set flags to enable  to exit on key
  999. '       SB         = True  ,saves background (text under edit field)
  1000. '
  1001. '       UPflag     = True  ,exitcode =  1
  1002. '       PGUPflag   = True  ,exitcode =  2
  1003. '       DNflag     = True  ,exitcode =  3
  1004. '       PGDNflag   = True  ,exitcode =  4
  1005. '       RETflag    = True  ,exitcode =  5
  1006. '       TABflag    = True  ,exitcode =  6
  1007. '       ESCflag    = True  ,exitcode =  7
  1008. '       F10flag    = true  ,exitcode =  9
  1009. '       ESC key restores field if True or False
  1010. '
  1011. '        force case if set.
  1012. '                        caseflag = 0 any case
  1013. '                                 = 1 for upper
  1014. '                                 = 2 for lower
  1015. '
  1016. '   sample how to handle exitcode after input routine (see program).
  1017. '
  1018. '   SELECT CASE ExitCode%
  1019. '
  1020. '       CASE 1 'what to do if uparrow key exit
  1021. '               could be
  1022. '               GOTO previous entry
  1023. '
  1024. '       CASE 2 'what to do if pageup key exit
  1025. '
  1026. '       CASE 3 'what to do if downarrow key exit
  1027. '               could be
  1028. '               GOTO next entry
  1029. '       CASE 4 'what to do if pagedown key exit
  1030. '
  1031. '       CASE 5 'what to do if enter key exit
  1032. '                could be accept entry
  1033. '       CASE 6 'what to do if tab key exit
  1034. '               'could be return to menu
  1035. '
  1036. '   END SELECT
  1037. '
  1038.    FUNCTION FES$ (SB, EFG, EBG, work$, format$, caseflag, Exitcode, UPflag, PGUPflag, DNflag, PGDNflag, RETflag, TABflag, escflag, F10flag)
  1039.  
  1040.       STATIC insertmode, curpos
  1041.       DIM Hlp$(10)
  1042.       ROW = CSRLIN
  1043.       col = POS(0)
  1044.       firsttime = 1
  1045.       LENGTH = LEN(format$)
  1046.  
  1047.       IF SB = TRUE THEN
  1048.       GetBackground ROW, col, ROW, col + LENGTH, ed$
  1049.       END IF
  1050.  
  1051.       FOR j = 1 TO LENGTH
  1052.      FChr$ = MID$(format$, j, 1)
  1053.      SELECT CASE FChr$
  1054.         CASE "~", "@", "0" TO "9", "#", "*", "|"
  1055.         CASE ELSE
  1056.            formatVALUES$ = formatVALUES$ + FChr$
  1057.      END SELECT
  1058.       NEXT j
  1059.       insertmode = 0
  1060.       SELECT CASE LEN(work$)
  1061.      CASE IS > LENGTH
  1062.         work$ = MID$(work$, 1, LENGTH)
  1063.      CASE IS < LENGTH
  1064.         work$ = work$ + STRING$(LENGTH - LEN(work$), SPACE)
  1065.       END SELECT
  1066.       temp$ = work$
  1067.       work$ = STRING$(LENGTH, " ")
  1068.       k = 1
  1069.       FOR j = 1 TO LENGTH
  1070.      Character$ = MID$(format$, j, 1)
  1071.      IF INSTR(formatVALUES$, Character$) THEN
  1072.         MID$(work$, j, 1) = Character$
  1073.      ELSE
  1074.         char$ = MID$(temp$, k, 1)
  1075.         MID$(work$, j, 1) = char$
  1076.         k = k + 1
  1077.      END IF
  1078.       NEXT j
  1079.       org$ = work$
  1080.       curpos = 1
  1081.       Exitcode = 0
  1082.       'COLOR efg, ebg
  1083.       LOCATE ROW, col
  1084.       'PRINT work$;
  1085.       pnc work$, ROW, col, EFG, EBG
  1086.  
  1087.       DO
  1088.      DO
  1089.         IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1090.            curpos = curpos + 1
  1091.         ELSE
  1092.            EXIT DO
  1093.         END IF
  1094.         IF curpos > LENGTH THEN
  1095.            curpos = LENGTH
  1096.            DO
  1097.           IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1098.              curpos = curpos - 1
  1099.           ELSE
  1100.              EXIT DO
  1101.           END IF
  1102.            LOOP
  1103.         END IF
  1104.      LOOP
  1105.      SELECT CASE curpos
  1106.         CASE IS > LENGTH
  1107.            curpos = LENGTH
  1108.         CASE IS < 1
  1109.            curpos = 1
  1110.      END SELECT
  1111.      LOCATE ROW, col
  1112.      'PRINT work$;
  1113.      pnc work$, ROW, col, EFG, EBG
  1114.  
  1115.      IF insertmode = TRUE THEN
  1116.         LOCATE ROW, col + curpos - 1, 1, 0, 15
  1117.      ELSE
  1118.         LOCATE ROW, col + curpos - 1, 1, 7, 7
  1119.      END IF
  1120.      IF INSTR(format$, "~") THEN
  1121.         LOCATE ROW, col + curpos - 1, 0, 7, 7
  1122.      END IF
  1123.      Choice$ = ""
  1124.      WHILE Choice$ = ""
  1125.         Choice$ = INKEY$
  1126.      WEND
  1127.      LOCATE , , 0
  1128.      IF LEN(Choice$) = 1 THEN
  1129.         special$ = MID$(format$, curpos, 1)
  1130.         keychoice = ASC(Choice$)
  1131.         SELECT CASE keychoice
  1132.            CASE ENTER
  1133.           IF RETflag = TRUE THEN
  1134.              Exitcode = 5
  1135.              EXIT DO
  1136.           END IF
  1137.            CASE TABKEY
  1138.           IF TABflag = TRUE THEN
  1139.              Exitcode = 6
  1140.              EXIT DO
  1141.           END IF
  1142.            CASE CTRLE
  1143.           work$ = STRING$(LENGTH, " ")
  1144.           temp$ = STRING$(LENGTH, " ")
  1145.           k = 1
  1146.           FOR j = 1 TO LENGTH
  1147.              Character$ = MID$(format$, j, 1)
  1148.              IF INSTR(formatVALUES$, Character$) THEN
  1149.             MID$(work$, j, 1) = Character$
  1150.              ELSE
  1151.             char$ = MID$(temp$, k, 1)
  1152.             MID$(work$, j, 1) = char$
  1153.             k = k + 1
  1154.              END IF
  1155.           NEXT j
  1156.           curpos = 1
  1157.            CASE ESC
  1158.           work$ = org$
  1159.           curpos = 1
  1160.           IF escflag = TRUE THEN
  1161.              Exitcode = 7
  1162.              EXIT DO
  1163.           END IF
  1164.         END SELECT
  1165.         SELECT CASE special$
  1166.            CASE "0" TO "9"
  1167.           IF Choice$ <= special$ THEN
  1168.              keychoice = ASC(Choice$)
  1169.           ELSE
  1170.              keychoice = 0
  1171.           END IF
  1172.            CASE "@"
  1173.           IF UCASE$(Choice$) >= "A" AND UCASE$(Choice$) <= "Z" OR Choice$ = " " OR Choice$ = CHR$(8) THEN
  1174.              keychoice = ASC(Choice$)
  1175.           ELSE
  1176.              keychoice = 0
  1177.           END IF
  1178.            CASE "*"
  1179.           IF UCASE$(Choice$) = "Y" OR UCASE$(Choice$) = "N" OR Choice$ = " " THEN
  1180.              keychoice = ASC(Choice$)
  1181.           ELSE
  1182.              keychoice = 0
  1183.           END IF
  1184.            CASE "|"
  1185.           IF UCASE$(Choice$) = "M" OR UCASE$(Choice$) = "F" OR Choice$ = " " THEN
  1186.              keychoice = ASC(Choice$)
  1187.           ELSE
  1188.              keychoice = 0
  1189.           END IF
  1190.            CASE "~"
  1191.           IF UCASE$(Choice$) = "" THEN
  1192.              keychoice = ASC(Choice$)
  1193.           ELSE
  1194.              keychoice = 0
  1195.           END IF
  1196.         END SELECT
  1197.         SELECT CASE keychoice
  1198.            CASE SPACE TO 126
  1199.           SELECT CASE caseflag
  1200.              CASE 1
  1201.             Choice$ = UCASE$(Choice$)
  1202.             keychoice = ASC(Choice$)
  1203.              CASE 2
  1204.             Choice$ = LCASE$(Choice$)
  1205.             keychoice = ASC(Choice$)
  1206.           END SELECT
  1207.           IF insertmode = 0 THEN
  1208.              MID$(work$, curpos, 1) = CHR$(keychoice)
  1209.              curpos = curpos + 1
  1210.              IF firsttime = 1 THEN
  1211.             work$ = Choice$ + STRING$(LENGTH - 1, " ")
  1212.             work$ = userSformat$((work$), format$)
  1213.             firsttime = 0
  1214.              END IF
  1215.           END IF
  1216.           IF insertmode = 1 THEN
  1217.              FOR j = 1 TO LENGTH
  1218.             Character$ = MID$(format$, j, 1)
  1219.             IF INSTR(formatVALUES$, Character$) THEN
  1220.                MID$(work$, j, 1) = CHR$(255)
  1221.                cursor = cursor + 1
  1222.             END IF
  1223.              NEXT j
  1224.              IF curpos < LENGTH THEN
  1225.             lwork$ = LTRIM$(LEFT$(work$, curpos - 1))
  1226.             rwork$ = RTRIM$(RIGHT$(work$, LENGTH - (curpos - 1)))
  1227.             work$ = LEFT$(lwork$ + Choice$ + rwork$, LENGTH)
  1228.             curpos = curpos + 1
  1229.              ELSE
  1230.             BEEP
  1231.              END IF
  1232.              work$ = RemoveCHAR$((work$), CHR$(255))
  1233.              work$ = userSformat$((work$), format$)
  1234.           END IF
  1235.            CASE 8, 127
  1236.           IF curpos > 1 THEN
  1237.              curpos = curpos - 1
  1238.              DO
  1239.             IF curpos > 1 THEN
  1240.                IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1241.                   curpos = curpos - 1
  1242.                ELSE
  1243.                   EXIT DO
  1244.                END IF
  1245.             ELSE
  1246.                EXIT DO
  1247.             END IF
  1248.              LOOP
  1249.              FOR j = 1 TO LENGTH
  1250.             Character$ = MID$(format$, j, 1)
  1251.             IF INSTR(formatVALUES$, Character$) THEN
  1252.                MID$(work$, j, 1) = CHR$(255)
  1253.             END IF
  1254.              NEXT j
  1255.              IF curpos < LENGTH THEN
  1256.             FOR j = curpos TO leng
  1257.                IF j < LENGTH - 1 THEN
  1258.                   char$ = MID$(work$, j + 1, 1)
  1259.                   MID$(work$, j, 1) = char$
  1260.                   MID$(work$, LENGTH, 1) = CHR$(255)
  1261.                END IF
  1262.             NEXT j
  1263.              END IF
  1264.              MID$(work$, curpos, 1) = CHR$(255)
  1265.              work$ = RemoveCHAR$((work$), CHR$(255))
  1266.              work$ = userSformat$((work$), format$)
  1267.           END IF
  1268.            CASE ELSE
  1269.         END SELECT
  1270.      ELSE
  1271.         keychoice = ASC(MID$(Choice$, 2))
  1272.         SELECT CASE keychoice
  1273.            CASE LEFTK
  1274.           IF curpos > 1 THEN
  1275.              curpos = curpos - 1
  1276.              DO
  1277.             IF curpos > 1 THEN
  1278.                IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1279.                   curpos = curpos - 1
  1280.                ELSE
  1281.                   EXIT DO
  1282.                END IF
  1283.             ELSE
  1284.                EXIT DO
  1285.             END IF
  1286.              LOOP
  1287.           END IF
  1288.            CASE RIGHTK
  1289.           curpos = curpos + 1
  1290.            CASE HOME
  1291.           curpos = 1
  1292.            CASE ENDK
  1293.           curpos = LENGTH
  1294.            CASE INSERTK
  1295.           insertmode = 1 - insertmode
  1296.            CASE DELETEK
  1297.           FOR j = 1 TO LENGTH
  1298.              Character$ = MID$(format$, j, 1)
  1299.              IF INSTR(formatVALUES$, Character$) THEN
  1300.             MID$(work$, j, 1) = CHR$(255)
  1301.              END IF
  1302.           NEXT j
  1303.           IF curpos < LENGTH THEN
  1304.              FOR j = curpos TO leng
  1305.             IF j < LENGTH - 1 THEN
  1306.                char$ = MID$(work$, j + 1, 1)
  1307.                MID$(work$, j, 1) = char$
  1308.                MID$(work$, LENGTH, 1) = CHR$(255)
  1309.             END IF
  1310.              NEXT j
  1311.           END IF
  1312.           MID$(work$, curpos, 1) = CHR$(255)
  1313.           work$ = RemoveCHAR$((work$), CHR$(255))
  1314.           work$ = userSformat$((work$), format$)
  1315.            CASE F1
  1316.           GetBackground 1, 1, 25, 80, hpbuf$
  1317.           Hlp$(1) = "- ALPHANUMERIC EDIT HELP -"
  1318.           Hlp$(2) = ""
  1319.           Hlp$(3) = "ESC    - restores edit field.                    " + CHR$(255)
  1320.           Hlp$(4) = "ENTER  - accepts entry and exits Edit.           " + CHR$(255)
  1321.           Hlp$(5) = "CTRL E - erases edit field.                      " + CHR$(255)
  1322.           Hlp$(6) = "DELETE, INSERT, and BACKSPACE function normal.   " + CHR$(255)
  1323.           Hlp$(7) = "ANY non edit key erases field if first time entry."
  1324.           Hlp$(8) = ""
  1325.           Hlp$(9) = "Press any key to continue"
  1326.           Message Hlp$(), 9, 1, WHITE + 8, RED, WHITE + 8, RED
  1327.           'COLOR efg, ebg
  1328.           PutBackground 1, 1, hpbuf$: hpbuf$ = ""
  1329.            CASE F10
  1330.           IF F10flag = TRUE THEN
  1331.              Exitcode = 9
  1332.              EXIT DO
  1333.           END IF
  1334.            CASE UPK
  1335.           IF UPflag = TRUE THEN
  1336.              Exitcode = 1
  1337.              EXIT DO
  1338.           END IF
  1339.            CASE PGUP
  1340.           IF PGUPflag = TRUE THEN
  1341.              Exitcode = 2
  1342.              EXIT DO
  1343.           END IF
  1344.            CASE PGDN
  1345.           IF PGDNflag = TRUE THEN
  1346.              Exitcode = 4
  1347.              EXIT DO
  1348.           END IF
  1349.            CASE DOWNK
  1350.           IF DNflag = TRUE THEN
  1351.              Exitcode = 3
  1352.              EXIT DO
  1353.           END IF
  1354.            CASE ELSE
  1355.         END SELECT
  1356.      END IF
  1357.      firsttime = 0
  1358.       LOOP WHILE Exitcode = 0
  1359.       'COLOR ebg, efg
  1360.       LOCATE ROW, col, CURSOROFF
  1361.       'PRINT work$;
  1362.       pnc work$, ROW, col, EBG, EFG
  1363.  
  1364.       FOR j = 1 TO LENGTH
  1365.      Character$ = MID$(format$, j, 1)
  1366.      char$ = MID$(work$, j, 1)
  1367.      IF INSTR(formatVALUES$, Character$) THEN
  1368.      ELSE
  1369.         IF char$ = CHR$(255) THEN
  1370.         ELSE
  1371.            tmp$ = tmp$ + char$
  1372.         END IF
  1373.      END IF
  1374.       NEXT j
  1375.       FES$ = RTRIM$(LTRIM$(tmp$))
  1376.       IF SB = TRUE THEN
  1377.       PutBackground ROW, col, ed$: ed$ = ""
  1378.       END IF
  1379.    END FUNCTION
  1380.  
  1381. '
  1382.    FUNCTION FileExists (FeName$)
  1383.  
  1384.     IF LEN(DIR$(FeName$)) = 0 THEN     'Ensure filespec is valid.
  1385.     FileExists = 0                   'It's not.
  1386.     ELSE
  1387.     FileExists = 1                   'It is.
  1388.     END IF
  1389.  
  1390.     ' code for QB45
  1391.  
  1392.     '  ffile = FREEFILE
  1393.     '  OPEN FeName$ FOR RANDOM AS ffile
  1394.     '  IF LOF(ffile) = 0 THEN
  1395.     '     FileExists = 0
  1396.     '  CLOSE ffile
  1397.     '  KILL FeName$
  1398.     '  ELSE
  1399.     '     FileExists = 1
  1400.     '  CLOSE ffile
  1401.     '  END IF
  1402.    
  1403.    END FUNCTION
  1404.  
  1405. '
  1406.    SUB FormatDEC (number$, beforeDEC, afterdec)
  1407.  
  1408.       LENGTH = LEN(number$)
  1409.       delimit = INSTR(number$, ".")
  1410.       IF delimit = 0 THEN
  1411.      beforeDEC = LENGTH
  1412.      afterdec = 0
  1413.       END IF
  1414.       IF delimit <> 0 THEN
  1415.      IF LEFT$(number$, 1) = "." THEN
  1416.         beforeDEC = 0
  1417.         afterdec = LENGTH - 1
  1418.      END IF
  1419.      IF RIGHT$(number$, 1) = "." THEN
  1420.         afterdec = 0
  1421.         beforeDEC = LENGTH - 1
  1422.      END IF
  1423.      IF delimit <> 1 OR delimit <> LENGTH THEN
  1424.         beforeDEC = delimit - 1
  1425.         afterdec = (LENGTH - beforeDEC) - 1
  1426.      END IF
  1427.       END IF
  1428.       IF LENGTH = 0 THEN
  1429.      beforeDEC = 0
  1430.      afterdec = 0
  1431.       END IF
  1432.    END SUB
  1433.  
  1434. '
  1435.    SUB GetBackground (row1, col1, row2, col2, buffer$) STATIC
  1436.       ' ========================================
  1437.       IF row1 >= 1 AND row2 <= MAXROW AND col1 >= 1 AND col2 <= MAXCOL THEN
  1438.      Wid = col2 - col1 + 1
  1439.      Hei = row2 - row1 + 1
  1440.      size = 4 + (2 * Wid * Hei)
  1441.      buffer$ = SPACE$(size)
  1442.      CALL getcopybox(row1, col1, row2, col2, buffer$)
  1443.       END IF
  1444.    END SUB
  1445.  
  1446.    FUNCTION GetDate$ STATIC
  1447.       Month$ = LEFT$(DATE$, 2)
  1448.       Day$ = MID$(DATE$, 4, 2)
  1449.       Year$ = RIGHT$(DATE$, 2)
  1450.       GetDate$ = Month$ + Day$ + Year$
  1451.    END FUNCTION
  1452.  
  1453. SUB GetDir (ans$)
  1454.  
  1455.       SHARED FileCount
  1456.       IF ans$ = "" THEN
  1457.      MsgOpt$(1) = "Enter a file specification:"
  1458.      ans$ = "*.*"
  1459.      DialogBox MsgOpt$(), 1, 1, 12, BLACK, WHITE, BLACK, WHITE, 3, ans$, "", Exk
  1460.       END IF
  1461.       filespec$ = ans$
  1462.       delimit = INSTR(filespec$, ".")
  1463.       IF delimit THEN
  1464.      FileName$ = LEFT$(filespec$, delimit - 1)
  1465.      fileext$ = RIGHT$(filespec$, LEN(filespec$) - (delimit))
  1466.       ELSE
  1467.      FileName$ = filespec$
  1468.      fileext$ = ""
  1469.       END IF
  1470.       IF LEN(filespec$) = 0 OR LEN(FileName$) > 8 OR LEN(fileext$) > 3 THEN
  1471.      MsgOpt$(1) = "You didn't enter a valid file specification."
  1472.      MsgOpt$(2) = ""
  1473.      MsgOpt$(3) = "Press any key to continue"
  1474.      Message MsgOpt$(), 3, 3, BLACK, WHITE + 8, BLACK, WHITE
  1475.      EXIT SUB
  1476.       END IF
  1477.       FileCount = GetFileCount(filespec$)
  1478.       IF FileCount THEN
  1479.      REDIM filelist$(FileCount)
  1480.       ELSE
  1481.      MsgOpt$(1) = "No files could be found."
  1482.      MsgOpt$(2) = ""
  1483.      MsgOpt$(3) = "Press any key to continue"
  1484.      Message MsgOpt$(), 3, 3, BLACK, WHITE + 8, BLACK, WHITE
  1485.      EXIT SUB
  1486.       END IF
  1487.       flist$ = DIR$(filespec$)
  1488.       delimit = INSTR(flist$, ".")
  1489.       IF delimit THEN
  1490.      FileName$ = LEFT$(flist$, delimit - 1)
  1491.      FileName$ = FileName$ + STRING$(8 - LEN(FileName$), " ")
  1492.      fileext$ = RIGHT$(flist$, LEN(flist$) - (delimit))
  1493.       ELSE
  1494.      FileName$ = flist$
  1495.      fileext$ = ""
  1496.       END IF
  1497.       filelist$(1) = FileName$ + "." + fileext$
  1498.       FOR Indx = 2 TO FileCount
  1499.      flist$ = DIR$
  1500.      delimit = INSTR(flist$, ".")
  1501.      IF delimit THEN
  1502.         FileName$ = LEFT$(flist$, delimit - 1)
  1503.         FileName$ = FileName$ + STRING$(8 - LEN(FileName$), " ")
  1504.         fileext$ = RIGHT$(flist$, LEN(flist$) - (delimit))
  1505.      ELSE
  1506.         FileName$ = flist$
  1507.         fileext$ = ""
  1508.      END IF
  1509.      filelist$(Indx) = FileName$ + "." + fileext$
  1510.       NEXT Indx
  1511.       IF FileCount <= 15 THEN
  1512.      leftREC = FileCount
  1513.       ELSE
  1514.      leftREC = 15
  1515.       END IF
  1516.  
  1517.       CALL quicksort(filelist$(), FileCount)
  1518.  
  1519. END SUB
  1520.  
  1521. '
  1522.    FUNCTION GetFileCount (filespec$)
  1523.       count = 0
  1524.       FileName$ = DIR$(filespec$)
  1525.       DO WHILE FileName$ <> ""
  1526.      count = count + 1
  1527.      FileName$ = DIR$
  1528.       LOOP
  1529.       GetFileCount = count
  1530.    END FUNCTION
  1531.  
  1532. '
  1533. FUNCTION GetPassword$ (FrmFG, FrmBG, GenFG, GenBG, DispPos, Ek)
  1534.  
  1535.       '  DispPos  -  Section of the screen to display on
  1536.       '              0=Top,1=Center,2=Bottom
  1537.       '  Ek       -  Exit Key
  1538.       '              5=Return, 7=ESC
  1539.       mop$ = "Enter your password ---->"
  1540.  
  1541.       LENGTH = LEN(mop$) + 1
  1542.       height = 1  ' Text height
  1543.       height = height + 2  'input line
  1544.       IF height > 25 THEN
  1545.      EXIT FUNCTION
  1546.       END IF
  1547.       IF LENGTH < 1 THEN
  1548.      EXIT FUNCTION
  1549.       END IF
  1550.  
  1551.       SELECT CASE DispPos
  1552.      CASE 0
  1553.         begin = 1
  1554.      CASE 1
  1555.         begin = (25 - height) / 2
  1556.      CASE 2
  1557.         begin = (25 - height) + 1
  1558.      CASE ELSE
  1559.         EXIT FUNCTION
  1560.       END SELECT
  1561.  
  1562.       Txwd = LENGTH
  1563.       BoxWidth = Txwd + 2
  1564.       LeftCol = (80 - (BoxWidth + 8)) / 2
  1565.       Wid = BoxWidth
  1566.       FrameType = 1
  1567.       Fill = 1
  1568.  
  1569.       GetBackground begin, LeftCol, begin + height + 1, LeftCol + Wid + 10, gpbuf$
  1570.  
  1571.       DrawBox begin, LeftCol, Wid - 1, height, FrameType, FrmFG, FrmBG, Fill, GenFG, GenBG, 1
  1572.       pnc mop$, begin + 1, LeftCol + 1, GenFG, GenBG
  1573.       DrawBox begin, LeftCol + LENGTH + 1, 10, 3, 1, FrmFG, FrmBG, Fill, GenFG, GenBG, 1
  1574.  
  1575.       xc = LeftCol + 2
  1576.       yc = begin + 1
  1577.       np = 0
  1578.  
  1579.       p$ = ""
  1580.  
  1581.       FOR x = 1 TO 8
  1582.  
  1583. next.char:
  1584.      PE$ = INKEY$
  1585.      IF PE$ = "" THEN
  1586.         GOTO next.char
  1587.      ELSE
  1588.         SELECT CASE PE$
  1589.         CASE "A" TO "Z", "a" TO "z", "0" TO "9"
  1590.          CASE ELSE
  1591.            GOTO carrage.ret
  1592.        END SELECT
  1593.      END IF
  1594.      p$ = p$ + PE$
  1595.      
  1596.      curpos = xc + LENGTH
  1597.      pnc "#", yc, curpos + np, GenFG, GenBG
  1598.      np = np + 1
  1599.  
  1600.       NEXT
  1601.  
  1602.       GetPassword$ = p$
  1603.       PutBackground begin, LeftCol, gpbuf$: gpbuf$ = ""
  1604.  
  1605.       EXIT FUNCTION
  1606.  
  1607. carrage.ret:
  1608.       IF ASC(PE$) = 13 THEN
  1609.      GOTO no.password
  1610.       ELSE
  1611.      GOTO next.char
  1612.       END IF
  1613. no.password:
  1614.  
  1615.       IF p$ = "" THEN
  1616.      p$ = "password"
  1617.       END IF
  1618.       GetPassword$ = p$
  1619.       PutBackground begin, LeftCol, gpbuf$: gpbuf$ = ""
  1620.  
  1621.    END FUNCTION
  1622.  
  1623.    FUNCTION GetShiftState (bit)
  1624.  
  1625.       ' =======================================================================
  1626.       ' Returns the shift state after calling interrupt 22
  1627.       '    bit 0 : RIGHT shift
  1628.       '        1 : LEFT shift
  1629.       '        2 : ctrl key
  1630.       '        3 : alt key
  1631.       '        4 : scroll lock
  1632.       '        5 : num lock
  1633.       '        6 : caps lock
  1634.       '        7 : insert state
  1635.       ' =======================================================================
  1636.  
  1637.       IF bit >= 0 AND bit <= 7 THEN
  1638.      DIM regs AS RegType
  1639.      regs.ax = 2 * 256
  1640.      Interrupt 22, regs, regs
  1641.  
  1642.      IF regs.ax AND 2 ^ bit THEN
  1643.         GetShiftState = TRUE
  1644.      ELSE
  1645.         GetShiftState = FALSE
  1646.      END IF
  1647.  
  1648.       ELSE
  1649.      GetShiftState = FALSE
  1650.       END IF
  1651.    END FUNCTION
  1652.  
  1653. SUB GetSingle (keycode, codetype) STATIC
  1654.         codetype = 0
  1655.  
  1656.         WHILE codetype = 0
  1657.             keypress$ = ""
  1658.             WHILE keypress$ = ""
  1659.                 keypress$ = INKEY$
  1660.             WEND
  1661.             codetype = LEN(keypress$)
  1662.             keycode = ASC(MID$(keypress$, codetype))
  1663.         WEND
  1664.     END SUB
  1665.  
  1666. DEFSNG A-Z
  1667.    SUB keysort (List$(), numelements%, Startpos%, Sortlen%) STATIC
  1668.  
  1669.       TempStackSize% = 50
  1670.       DIM TempStack%(TempStackSize%)
  1671. Initialize:
  1672.       TempStackPnt% = 0
  1673.       top% = LBOUND(List$)
  1674.       Bottom% = numelements%
  1675. DoSort:
  1676.       temp$ = MID$(List$((Bottom% + top%) / 2), Startpos%, Sortlen%)
  1677.       I% = top%
  1678.       j% = Bottom%
  1679. Part.Exchg:
  1680.       DO WHILE MID$(List$(I%), Startpos%, Sortlen%) < temp$
  1681.      I% = I% + 1
  1682.       LOOP
  1683.       DO WHILE MID$(List$(j%), Startpos%, Sortlen%) > temp$
  1684.      j% = j% - 1
  1685.       LOOP
  1686.       IF I% > j% THEN
  1687.      GOTO PushTempStack
  1688.       END IF
  1689.       IF I% < j% THEN
  1690.      SWAP List$(I%), List$(j%)
  1691.       END IF
  1692.       I% = I% + 1
  1693.       j% = j% - 1
  1694.       IF I% <= j% THEN
  1695.      GOTO Part.Exchg
  1696.       END IF
  1697. PushTempStack:
  1698.       IF I% < Bottom% THEN
  1699.      TempStack%(TempStackPnt%) = I%
  1700.      TempStack%(TempStackPnt% + 1) = Bottom%
  1701.      TempStackPnt% = TempStackPnt% + 2
  1702.       END IF
  1703.       Bottom% = j%
  1704.       IF top% < Bottom% THEN
  1705.      GOTO DoSort
  1706.       END IF
  1707.       IF TempStackPnt% = 0 THEN
  1708.      GOTO Exit.Sort
  1709.       END IF
  1710.       TempStackPnt% = TempStackPnt% - 2
  1711.       top% = TempStack%(TempStackPnt%)
  1712.       Bottom% = TempStack%(TempStackPnt% + 1)
  1713.       GOTO DoSort
  1714. Exit.Sort:
  1715.       ERASE TempStack%
  1716.       temp$ = ""
  1717.    END SUB
  1718.  
  1719. DEFINT A-Z
  1720.    FUNCTION Maximum (v1, v2)
  1721.       IF v1 >= v2 THEN
  1722.      Maximum = v1
  1723.       ELSE
  1724.      Maximum = v2
  1725.       END IF
  1726.    END FUNCTION
  1727.  
  1728. '
  1729.    FUNCTION MenuBar (ROW, col, MenuStr$, MenuFore, MenuBack, Reversed, SP)
  1730.       DIM menu(1 TO 20) AS MenuData
  1731.       MenuLen = LEN(MenuStr$)
  1732.       IF MenuLen + col > 80 THEN
  1733.      CLS
  1734.      LOCATE 10, 20
  1735.      PRINT "Cannot create menu - String too long";
  1736.      LOCATE 11, 20
  1737.      PRINT "Please shorten length of either Menu$ or Col";
  1738.      END
  1739.       END IF
  1740.       menuCHAR = 0
  1741.       pnc MenuStr$, ROW, col, MenuFore, MenuBack
  1742.       FOR menuCHAR = col TO col + MenuLen - 1
  1743.      Test = SCREEN(ROW, menuCHAR)
  1744.      IF Test > 64 AND Test < 91 THEN
  1745.         menunum = menunum + 1
  1746.         menu(menunum).WordStart = menuCHAR
  1747.         menu(menunum).MenuLetter = CHR$(Test)
  1748.         menu(menunum).MenuWord = CHR$(Test)
  1749.         menu(menunum).WordLen = 1
  1750.         CharString$ = CHR$(Test)
  1751.      ELSEIF Test <> 32 THEN
  1752.         CharString$ = CharString$ + CHR$(Test)
  1753.         menu(menunum).MenuWord = CharString$
  1754.         menu(menunum).WordLen = menu(menunum).WordLen + 1
  1755.      END IF
  1756.       NEXT menuCHAR
  1757.       menunum = SP
  1758.       DO
  1759.      COLOR , MenuBack
  1760.      FOR menuCHAR = 1 TO 20
  1761.         IF menu(menuCHAR).WordStart > 0 THEN
  1762.            COLOR Reversed
  1763.            LOCATE ROW, menu(menuCHAR).WordStart
  1764.            PRINT menu(menuCHAR).MenuLetter;
  1765.            Lastmenu = menuCHAR
  1766.         ELSE
  1767.            menuCHAR = 20
  1768.         END IF
  1769.      NEXT menuCHAR
  1770.      LOCATE ROW, menu(menunum).WordStart
  1771.      COLOR WHITE + 8, Reversed
  1772.      PRINT RTRIM$(menu(menunum).MenuWord);
  1773.      DO
  1774.         Response$ = UCASE$(INKEY$)
  1775.         SELECT CASE Response$
  1776.            CASE CHR$(0) + CHR$(75)
  1777.           GOSUB ResetSel
  1778.           menunum = menunum - 1
  1779.           IF menunum < 1 THEN
  1780.              menunum = Lastmenu
  1781.           END IF
  1782.            CASE CHR$(0) + CHR$(77)
  1783.           GOSUB ResetSel
  1784.           menunum = menunum + 1
  1785.           IF menunum > Lastmenu THEN
  1786.              menunum = 1
  1787.           END IF
  1788.            CASE CHR$(13)
  1789.           MenuBar = menunum
  1790.            CASE "A" TO "Z"
  1791.           FOR Compare = 1 TO 20
  1792.              IF Response$ = menu(Compare).MenuLetter THEN
  1793.             menunum = Compare
  1794.             MenuBar = menunum
  1795.             Response$ = CHR$(13)
  1796.              END IF
  1797.           NEXT Compare
  1798.            CASE ELSE
  1799.         END SELECT
  1800.      LOOP UNTIL Response$ <> ""
  1801.       LOOP UNTIL Response$ = CHR$(13)
  1802.       EXIT FUNCTION
  1803. ResetSel:
  1804.       LOCATE ROW, col
  1805.       COLOR MenuFore, MenuBack
  1806.       LOCATE ROW, menu(menunum).WordStart
  1807.       PRINT RTRIM$(menu(menunum).MenuWord);
  1808.       COLOR Reversed
  1809.       LOCATE ROW, menu(menunum).WordStart
  1810.       PRINT RTRIM$(menu(menunum).MenuLetter);
  1811.       RETURN
  1812.    END FUNCTION
  1813.  
  1814. '
  1815.    FUNCTION MenuWindow (ROW, col, MenuStr$, title$, MenuFore, MenuBack, Reversed, allowesc)
  1816.       DIM menu(1 TO 20) AS MenuData
  1817.       Array$ = Str2Token$(MenuStr$, "\")
  1818.       I = 0
  1819.       LENGTH = 0
  1820.       DO
  1821.      I = I + 1
  1822.      moption$(I) = Array$
  1823.      IF LEN(moption$(I)) > LENGTH THEN
  1824.         LENGTH = LEN(moption$(I))
  1825.      END IF
  1826.      Array$ = Str2Token$("", "\")
  1827.       LOOP WHILE Array$ <> ""
  1828.  
  1829.       menuCHAR = 0
  1830.  
  1831.       IF col > 80 - LENGTH THEN
  1832.      col = (80 - LENGTH)
  1833.       END IF
  1834.       IF ROW > 23 - I THEN
  1835.      ROW = (24 - I)
  1836.       END IF
  1837.       IF col <= 1 THEN
  1838.      col = (80 - LENGTH) / 2
  1839.       END IF
  1840.       IF ROW <= 1 THEN
  1841.      ROW = (24 - I) / 2
  1842.       END IF
  1843.       GetBackground ROW - 1, col - 1, ROW + I + 2, col + LENGTH + 4, mwbuf$
  1844.       FOR j = 1 TO I
  1845.      pnc " " + moption$(j) + STRING$(LENGTH - LEN(moption$(j)) + 1, " "), ROW + j, col, MenuFore, MenuBack
  1846.       NEXT j
  1847.       LeftCol = col - 1: TopRow = ROW: endcol = col + LENGTH: endrow = ROW + j
  1848.       DrawBox TopRow, LeftCol, LENGTH + 4, j + 1, 2, MenuFore, MenuBack, 0, 7, 0, 1
  1849.       tx$ = RTRIM$(title$)
  1850.       IF LEN(tx$) > 0 THEN
  1851.      lgth = endcol - LeftCol
  1852.      IF (LEN(tx$) + 2) < lgth THEN
  1853.         pnc "[" + tx$ + "]", TopRow, LeftCol + INT(lgth / 2 - LEN(tx$) / 2), MenuFore + 1, MenuBack
  1854.      ELSE
  1855.         pnc LEFT$("|" + tx$ + "|", (endcol - LeftCol + 3)), TopRow - 1, LeftCol + 3, MenuFore, MenuBack
  1856.      END IF
  1857.       END IF
  1858.       FOR menuCHAR = ROW + 1 TO ROW + I
  1859.      Test = SCREEN(menuCHAR, col + 1)
  1860.      SELECT CASE Test
  1861.         CASE 64 TO 91, 47 TO 58
  1862.            menunum = menunum + 1
  1863.            menu(menunum).WordStart = menuCHAR
  1864.            menu(menunum).MenuLetter = CHR$(Test)
  1865.            menu(menunum).MenuWord = CHR$(Test)
  1866.            menu(menunum).WordLen = 1
  1867.            CharString$ = CHR$(Test)
  1868.         CASE IS <> 32
  1869.            CharString$ = CharString$ + CHR$(Test)
  1870.            menu(menunum).MenuWord = CharString$
  1871.            menu(menunum).WordLen = menu(menunum).WordLen + 1
  1872.      END SELECT
  1873.       NEXT menuCHAR
  1874.       menunum = 1
  1875.       DO
  1876.      FOR menuCHAR = 1 TO 20
  1877.         IF menu(menuCHAR).WordStart > 0 THEN
  1878.            pnc menu(menuCHAR).MenuLetter, menu(menuCHAR).WordStart, col + 1, Reversed, MenuBack
  1879.            Lastmenu = menuCHAR
  1880.         ELSE
  1881.            menuCHAR = 20
  1882.         END IF
  1883.      NEXT menuCHAR
  1884.      pnc " " + RTRIM$(moption$(menunum)) + STRING$(LENGTH - LEN(moption$(menunum)) + 1, " "), menu(menunum).WordStart, col, WHITE + 8, Reversed
  1885.      DO
  1886.         Response$ = UCASE$(INKEY$)
  1887.         SELECT CASE Response$
  1888.            CASE CHR$(0) + CHR$(72)
  1889.           pnc " " + RTRIM$(moption$(menunum)) + STRING$(LENGTH - LEN(moption$(menunum)) + 1, " "), menu(menunum).WordStart, col, MenuFore, MenuBack
  1890.           pnc " " + menu(menunum).MenuLetter, menu(menunum).WordStart, col, MenuFore, MenuBack
  1891.           menunum = menunum - 1
  1892.           IF menunum < 1 THEN
  1893.              menunum = Lastmenu
  1894.           END IF
  1895.            CASE CHR$(0) + CHR$(80)
  1896.           pnc " " + RTRIM$(moption$(menunum)) + STRING$(LENGTH - LEN(moption$(menunum)) + 1, " "), menu(menunum).WordStart, col, MenuFore, MenuBack
  1897.           pnc " " + menu(menunum).MenuLetter, menu(menunum).WordStart, col, MenuFore, MenuBack
  1898.           menunum = menunum + 1
  1899.           IF menunum > Lastmenu THEN
  1900.              menunum = 1
  1901.           END IF
  1902.            CASE CHR$(13)
  1903.           MenuWindow = menunum
  1904.            CASE CHR$(27)
  1905.           IF allowesc = 1 THEN
  1906.           Response$ = CHR$(13)
  1907.           MenuWindow = 0
  1908.           END IF
  1909.            CASE "A" TO "Z", "0" TO "9"
  1910.           FOR Compare = 1 TO 20
  1911.              IF Response$ = menu(Compare).MenuLetter THEN
  1912.             menunum = Compare
  1913.             MenuWindow = menunum
  1914.             Response$ = CHR$(13)
  1915.              END IF
  1916.           NEXT Compare
  1917.            CASE ELSE
  1918.         END SELECT
  1919.      LOOP UNTIL Response$ <> ""
  1920.       LOOP UNTIL Response$ = CHR$(13)
  1921.       PutBackground ROW - 1, col - 1, mwbuf$: mwbuf$ = ""
  1922.    END FUNCTION
  1923.  
  1924. '
  1925. SUB Message (mop$(), lines, Border, FrmFG, FrmBG, GenFG, GenBG)
  1926.       maxwidth = 0
  1927.       El = UBOUND(mop$, 1)
  1928.       IF lines > El THEN
  1929.      EXIT SUB
  1930.       END IF
  1931.       FOR j = 1 TO lines
  1932.      Trim mop$(j)
  1933.      maxwidth = Maximum(maxwidth, LEN(mop$(j)))
  1934.       NEXT j
  1935.       maxwidth = maxwidth + 4
  1936.       maxheight = lines + 4
  1937.       IF maxwidth > 80 THEN
  1938.      EXIT SUB
  1939.       END IF
  1940.       IF maxheight > 24 THEN
  1941.      EXIT SUB
  1942.       END IF
  1943.       TopRow = 24 - maxheight
  1944.       TopRow = TopRow / 2
  1945.       LeftCol = 80 - maxwidth
  1946.       LeftCol = LeftCol / 2
  1947.       GetBackground TopRow, LeftCol, TopRow + maxheight + 1, LeftCol + maxwidth + 1, msbuf$
  1948.       DrawBox TopRow, LeftCol, maxwidth, maxheight, Border, FrmFG, FrmBG, 1, GenFG, GenBG, 1
  1949.  
  1950.       FOR j = 1 TO lines
  1951.      Diff = (maxwidth - LEN(mop$(j)))
  1952.      IF Diff THEN
  1953.         Diff = Diff / 2
  1954.      END IF
  1955.      TextToPrint$ = mop$(j)
  1956.      ROW = j + TopRow + 1
  1957.      col = LeftCol + Diff
  1958.      pnc TextToPrint$, ROW, col, GenFG, GenBG
  1959.       NEXT j
  1960.       DO
  1961.      key$ = INKEY$
  1962.       LOOP UNTIL key$ <> ""
  1963.       PutBackground TopRow, LeftCol, msbuf$: msbuf$ = ""
  1964.    END SUB
  1965.  
  1966.    FUNCTION Minimum (v1, v2)
  1967.       IF v1 >= v2 THEN
  1968.      Minimum = v2
  1969.       ELSE
  1970.      Minimum = v1
  1971.       END IF
  1972.    END FUNCTION
  1973.  
  1974. '
  1975.    SUB msg.nodata
  1976.    DIM DispLine$(4)
  1977.    DispLine$(1) = " There are no records "
  1978.    DispLine$(2) = "in the database !"
  1979.    DispLine$(3) = ""
  1980.    DispLine$(4) = "Press any key to continue"
  1981.    Message DispLine$(), 4, 3, BLACK, WHITE, balck, WHITE
  1982.    END SUB
  1983.  
  1984.    SUB MsgLine (msg$, lin, mfg, mfb) STATIC
  1985.  
  1986.     CALL pnc(SPACE$(77), lin, 2, mfg, mfb)
  1987.       ml = 80 - LEN(msg$)
  1988.       mp = ml \ 2
  1989.     CALL pnc(msg$, lin, mp, mfg, mfb)
  1990.  
  1991.    END SUB
  1992.  
  1993.   SUB nodata
  1994.    DIM DispLine$(4)
  1995.    DispLine$(1) = "There are no Records"
  1996.    DispLine$(2) = "in the database !"
  1997.    DispLine$(3) = ""
  1998.    DispLine$(4) = "Press any key to continue"
  1999.    Message DispLine$(), 4, 3, BLACK, WHITE, balck, WHITE
  2000.  
  2001.   END SUB
  2002.  
  2003. '
  2004.    FUNCTION OpenFile (FileName$, reclen)
  2005.       IF FileExists(FileName$) THEN
  2006.      w = FREEFILE
  2007.      IF w THEN
  2008.         OPEN FileName$ FOR RANDOM AS #w LEN = reclen
  2009.         OpenFile = w
  2010.      ELSE
  2011.         OpenFile = 0
  2012.      END IF
  2013.       ELSE
  2014.      OpenFile = 0
  2015.       END IF
  2016.    END FUNCTION
  2017.  
  2018.    SUB PadStr (a$, b)
  2019.       IF LEN(a$) >= b THEN
  2020.      a$ = LEFT$(a$, b)
  2021.       ELSE
  2022.      a$ = a$ + STRING$(b - LEN(a$), 32)
  2023.       END IF
  2024.    END SUB
  2025.  
  2026. '
  2027. SUB PutBackground (ROW, col, buffer$)
  2028.       ' =======================================================================
  2029.       ' This sub checks the boundries before executing the put command
  2030.       ' =======================================================================
  2031.       IF ROW >= 1 AND ROW <= MAXROW AND col >= 1 AND col <= MAXCOL THEN
  2032.      CALL putcopybox(ROW, col, buffer$)
  2033.       END IF
  2034.    END SUB
  2035.  
  2036. DEFSNG A-U, W-Z
  2037. DEFDBL V
  2038.    SUB quicksort (fl$(), Elements%) STATIC
  2039.       DIM tempstk%(30, 2)
  2040.       s% = 1
  2041.       tempstk%(1, 1) = 1
  2042.       tempstk%(1, 2) = Elements%
  2043.       DO WHILE s% <> 0
  2044.      l% = tempstk%(s%, 1)
  2045.      r% = tempstk%(s%, 2)
  2046.      s% = s% - 1
  2047.      DO WHILE l% < r%
  2048.         I% = l%
  2049.         j% = r%
  2050.         x$ = fl$((l% + r%) / 2)
  2051.         DO WHILE j% >= I%
  2052.            DO WHILE fl$(I%) < x$
  2053.           I% = I% + 1
  2054.            LOOP
  2055.            DO WHILE x$ < fl$(j%)
  2056.           j% = j% - 1
  2057.            LOOP
  2058.            IF I% <= j% THEN
  2059.           SWAP fl$(j%), fl$(I%)
  2060.           I% = I% + 1
  2061.           j% = j% - 1
  2062.            END IF
  2063.         LOOP
  2064.         IF I% < r% THEN
  2065.            s% = s% + 1
  2066.            tempstk%(s%, 1) = I%
  2067.            tempstk%(s%, 2) = r%
  2068.         END IF
  2069.         r% = j%
  2070.      LOOP
  2071.       LOOP
  2072.    END SUB
  2073.  
  2074. DEFINT A-Z
  2075. '
  2076.    SUB Reg16to8 (Reg16 AS LONG, RegHigh AS INTEGER, RegLow AS INTEGER)
  2077.  
  2078.       RegHigh = Reg16 \ 256
  2079.       RegLow = Reg16 MOD 256
  2080.  
  2081.    END SUB
  2082.  
  2083. '
  2084.    SUB Reg8to16 (Reg16 AS LONG, RegHigh AS INTEGER, RegLow AS INTEGER)
  2085.  
  2086.       Reg16 = RegHigh * 256 + RegLow
  2087.  
  2088.    END SUB
  2089.  
  2090.    SUB Reg8to4 (Reg8, RegHigh, RegLow)
  2091.       RegHigh = Reg8 \ 16
  2092.       RegLow = Reg8 MOD 16
  2093.    END SUB
  2094.  
  2095.    FUNCTION RemoveCHAR$ (userstring$, skip$)
  2096.       LENGTH = LEN(userstring$)
  2097.       Character$ = ""
  2098.       FOR k = 1 TO LENGTH
  2099.      char$ = MID$(userstring$, k, 1)
  2100.      IF char$ = skip$ THEN
  2101.      ELSE
  2102.         Character$ = Character$ + char$
  2103.      END IF
  2104.       NEXT
  2105.       RemoveCHAR$ = Character$
  2106.    END FUNCTION
  2107.  
  2108.    FUNCTION removeformat$ (work$, format$) STATIC
  2109.       IF LEN(work$) < LEN(format$) THEN
  2110.      EXIT FUNCTION
  2111.       END IF
  2112.       LENGTH = LEN(format$)
  2113.       FOR j = 1 TO LENGTH
  2114.      FChr$ = MID$(format$, j, 1)
  2115.      SELECT CASE FChr$
  2116.         CASE "~", "@", "0" TO "9", "#", "*"
  2117.         CASE ELSE
  2118.            formatVALUES$ = formatVALUES$ + FChr$
  2119.      END SELECT
  2120.       NEXT j
  2121.       FOR j = 1 TO LENGTH
  2122.      Character$ = MID$(format$, j, 1)
  2123.      char$ = MID$(work$, j, 1)
  2124.      IF INSTR(formatVALUES$, Character$) THEN
  2125.      ELSE
  2126.         IF char$ = CHR$(255) THEN
  2127.         ELSE
  2128.            tmp$ = tmp$ + char$
  2129.         END IF
  2130.      END IF
  2131.       NEXT j
  2132.       removeformat$ = RTRIM$(LTRIM$(tmp$))
  2133.    END FUNCTION
  2134.  
  2135. '
  2136.    FUNCTION SelBox (TempKey$(), numele, lenview, diswide, fg, bg, rev) STATIC
  2137.       numele = numele
  2138.       diswide = diswide + 1
  2139.       COLOR fg, bg
  2140.  
  2141.       GetBackground 21, 5, 23, 75, sfm$
  2142.       CALL drawwind(21, 5, 23, 75, 2, 0)
  2143.       'color frame
  2144.       CALL Colorwind(21, 5, 23, 75, 0, 1, BLACK, WHITE)
  2145.  
  2146.       CenterText "                   Select From List and Press Enter                  ", 22, BLACK, WHITE
  2147.  
  2148.       LOCATE , , 0
  2149.       FOR j = 1 TO numele
  2150.      IF LEN(TempKey$(j)) < diswide THEN
  2151.         TempKey$(j) = TempKey$(j) + STRING$(diswide - LEN(TempKey$(j)), 32)
  2152.      END IF
  2153.       NEXT j
  2154.       height = lenview + 2
  2155.       LeftCol = (80 / 2) - (diswide / 2)
  2156.       TopRow = (25 - height) / 2
  2157.       rightcol = LeftCol + diswide - 1
  2158.       botrow = TopRow + height - 4
  2159.       rtside = LeftCol + diswide + 1
  2160.       topline = TopRow + 1
  2161.       botline = TopRow + lenview + 2
  2162.       GetBackground topline, LeftCol, botline + 1, rtside + 2, sbbuf$
  2163.       DrawBox topline, LeftCol, diswide + 2, height, 2, fg, bg, 1, fg, bg, 1
  2164.       lup = 0
  2165.       linepos = 1
  2166.       listpos = 1
  2167.       WHILE lup = 0
  2168.      FOR j = 1 TO lenview
  2169.         IF (j - 1) + listpos <= numele THEN
  2170.            IF j = linepos THEN
  2171.           COLOR bg + 8, rev
  2172.           LOCATE j + TopRow + 1, LeftCol + 1
  2173.           PRINT TempKey$(j - 1 + listpos);
  2174.            END IF
  2175.            IF j <> linepos THEN
  2176.           COLOR fg, bg
  2177.           LOCATE j + TopRow + 1, LeftCol + 1
  2178.           PRINT TempKey$(j - 1 + listpos);
  2179.            END IF
  2180.         ELSE
  2181.            LOCATE j + TopRow + 1, LeftCol + 1
  2182.            PRINT STRING$(diswide, 32);
  2183.         END IF
  2184.      NEXT j
  2185.      keytype = 0
  2186.      WHILE keytype = 0
  2187.         Choice$ = ""
  2188.         WHILE Choice$ = ""
  2189.            Choice$ = INKEY$
  2190.         WEND
  2191.         keytype = LEN(Choice$)
  2192.         keychoice = ASC(MID$(Choice$, keytype))
  2193.      WEND
  2194.      IF keytype = 2 THEN
  2195.         SELECT CASE keychoice
  2196.            CASE 72
  2197.           linepos = linepos - 1
  2198.            CASE 80
  2199.           linepos = linepos + 1
  2200.            CASE 81
  2201.           listpos = listpos + lenview
  2202.            CASE 73
  2203.           listpos = listpos - lenview
  2204.            CASE 79
  2205.           listpos = (numele + 1) - lenview
  2206.           linepos = lenview
  2207.            CASE 71
  2208.           listpos = 1
  2209.           linepos = 1
  2210.         END SELECT
  2211.      END IF
  2212.      IF keytype = 1 THEN
  2213.         IF keychoice = 13 THEN
  2214.            lup = 1
  2215.         END IF
  2216.      END IF
  2217.      IF linepos < 1 THEN
  2218.         listpos = listpos - 1
  2219.         linepos = 1
  2220.      END IF
  2221.      IF linepos > lenview THEN
  2222.         listpos = listpos + 1
  2223.         linepos = lenview
  2224.      END IF
  2225.      IF (listpos - 1 + lenview) > numele THEN
  2226.         listpos = numele - lenview + 1
  2227.      END IF
  2228.      IF linepos > numele THEN
  2229.         linepos = numele
  2230.      END IF
  2231.      IF listpos < 1 THEN
  2232.         listpos = 1
  2233.      END IF
  2234.       WEND
  2235.       SelBox = listpos + linepos - 1
  2236.       COLOR 7, 0
  2237.       PutBackground topline, LeftCol, sbbuf$: sbbuf$ = ""
  2238.       PutBackground 21, 5, sfm$: sfm$ = ""
  2239.    END FUNCTION
  2240.  
  2241. '
  2242.    FUNCTION SelFiles$ (userfilespec$)
  2243.  
  2244.       IF LEN(userfilespec$) = 0 THEN
  2245.      MsgOpt$(1) = "Enter a file specification:"
  2246.      userfilespec$ = "*.*"
  2247.  
  2248.       CALL DialogBox(MsgOpt$(), 1, 1, 12, BLACK, WHITE, BLACK, WHITE, 1, userfilespec$, "", Exk)
  2249.  
  2250.       END IF
  2251.  
  2252.       filespec$ = userfilespec$
  2253.       delimit = INSTR(filespec$, ".")
  2254.       IF delimit THEN
  2255.      FileName$ = LEFT$(filespec$, delimit - 1)
  2256.      fileext$ = RIGHT$(filespec$, LEN(filespec$) - (delimit))
  2257.       ELSE
  2258.      FileName$ = filespec$
  2259.      fileext$ = ""
  2260.       END IF
  2261.       IF LEN(filespec$) = 0 OR LEN(FileName$) > 8 OR LEN(fileext$) > 3 THEN
  2262.      MsgOpt$(1) = "You didn't enter a valid file specification."
  2263.      MsgOpt$(2) = ""
  2264.      MsgOpt$(3) = "Press any key to continue"
  2265.      Message MsgOpt$(), 3, 3, BLACK, WHITE + 8, BLACK, WHITE
  2266.      EXIT FUNCTION
  2267.       END IF
  2268.       FileCount = GetFileCount(filespec$)
  2269.       IF FileCount THEN
  2270.      REDIM filelist$(FileCount)
  2271.       ELSE
  2272.      MsgOpt$(1) = "No files could be found."
  2273.      MsgOpt$(2) = ""
  2274.      MsgOpt$(3) = "Press any key to continue"
  2275.      Message MsgOpt$(), 3, 3, BLACK, WHITE + 8, BLACK, WHITE
  2276.      EXIT FUNCTION
  2277.       END IF
  2278.       flist$ = DIR$(filespec$)
  2279.       delimit = INSTR(flist$, ".")
  2280.       IF delimit THEN
  2281.      FileName$ = LEFT$(flist$, delimit - 1)
  2282.      FileName$ = FileName$ + STRING$(8 - LEN(FileName$), " ")
  2283.      fileext$ = RIGHT$(flist$, LEN(flist$) - (delimit))
  2284.       ELSE
  2285.      FileName$ = flist$
  2286.      fileext$ = ""
  2287.       END IF
  2288.       filelist$(1) = FileName$ + "." + fileext$
  2289.       FOR Indx = 2 TO FileCount
  2290.      flist$ = DIR$
  2291.      delimit = INSTR(flist$, ".")
  2292.      IF delimit THEN
  2293.         FileName$ = LEFT$(flist$, delimit - 1)
  2294.         FileName$ = FileName$ + STRING$(8 - LEN(FileName$), " ")
  2295.         fileext$ = RIGHT$(flist$, LEN(flist$) - (delimit))
  2296.      ELSE
  2297.         FileName$ = flist$
  2298.         fileext$ = ""
  2299.      END IF
  2300.      filelist$(Indx) = FileName$ + "." + fileext$
  2301.       NEXT Indx
  2302.       IF FileCount <= 10 THEN
  2303.      leftREC = FileCount
  2304.       ELSE
  2305.      leftREC = 10
  2306.       END IF
  2307.  
  2308.       CALL quicksort(filelist$(), FileCount)
  2309.       usel = SelBox(filelist$(), UBOUND(filelist$), leftREC, 12, BLACK, WHITE, RED)
  2310.       IF usel = 0 THEN
  2311.      SelFiles$ = ""
  2312.       ELSE
  2313.      SelFiles$ = RemoveCHAR$((filelist$(usel)), " ")
  2314.       END IF
  2315.  
  2316.    END FUNCTION
  2317.  
  2318.    FUNCTION Str2Token$ (Srce$, DELIM$)
  2319.       STATIC Start, SaveStr$
  2320.       IF Srce$ <> "" THEN
  2321.      Start = 1
  2322.      SaveStr$ = Srce$
  2323.       END IF
  2324.       BegPos = Start
  2325.       Ln = LEN(SaveStr$)
  2326.       WHILE BegPos <= Ln AND INSTR(DELIM$, MID$(SaveStr$, BegPos, 1)) <> 0
  2327.      BegPos = BegPos + 1
  2328.       WEND
  2329.       IF BegPos > Ln THEN
  2330.      Str2Token$ = ""
  2331.      EXIT FUNCTION
  2332.       END IF
  2333.       EndPos = BegPos
  2334.       WHILE EndPos <= Ln AND INSTR(DELIM$, MID$(SaveStr$, EndPos, 1)) = 0
  2335.      EndPos = EndPos + 1
  2336.       WEND
  2337.       Str2Token$ = MID$(SaveStr$, BegPos, EndPos - BegPos)
  2338.       Start = EndPos
  2339.    END FUNCTION
  2340.  
  2341. FUNCTION strval$ (a%)
  2342. strval$ = MID$(STR$(a%), 2)
  2343. END FUNCTION
  2344.  
  2345.    SUB Trim (a$)
  2346.       a$ = RTRIM$(LTRIM$(a$))
  2347.    END SUB
  2348.  
  2349.    FUNCTION userNformat$ (wrk$, format$)
  2350.       work$ = wrk$
  2351.       LENGTH = LEN(format$)
  2352.       SELECT CASE LEN(work$)
  2353.      CASE IS > LENGTH
  2354.         work$ = RIGHT$(work$, LENGTH)
  2355.      CASE IS < LENGTH
  2356.         work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  2357.       END SELECT
  2358.       IF INSTR(format$, ".") THEN
  2359.      decflag = 1
  2360.      IF INSTR(work$, ".") THEN
  2361.         FormatDEC (work$), bforeDEC, aftDEC
  2362.         FormatDEC (format$), beforeDEC, afterdec
  2363.         work$ = RemoveCHAR$((work$), ".")
  2364.         IF afterdec > aftDEC THEN
  2365.            work$ = work$ + STRING$(afterdec - (aftDEC - 1), "0")
  2366.         END IF
  2367.         IF afterdec < aftDEC THEN
  2368.            work$ = STRING$(aftDEC - (afterdec - 1), " ") + LEFT$(work$, beforeDEC + (afterdec - 1))
  2369.         END IF
  2370.      ELSE
  2371.         FormatDEC format$, beforeDEC, afterdec
  2372.         work$ = work$ + STRING$(afterdec + 1, "0")
  2373.      END IF
  2374.       ELSE
  2375.      FormatDEC (work$), beforeDEC, afterdec
  2376.      work$ = LEFT$(work$, beforeDEC)
  2377.      afterdec = 0
  2378.      work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  2379.      decflag = 0
  2380.       END IF
  2381.       SELECT CASE LEN(work$)
  2382.      CASE IS > LENGTH
  2383.         work$ = RIGHT$(work$, LENGTH)
  2384.      CASE IS < LENGTH
  2385.         IF decflag THEN
  2386.            work$ = STRING$(LENGTH - LEN(work$) - 1, " ") + work$
  2387.         ELSE
  2388.            work$ = STRING$(LENGTH - LEN(work$), " ") + work$
  2389.         END IF
  2390.       END SELECT
  2391.       temp$ = work$
  2392.       work$ = STRING$(LENGTH, " ")
  2393.       k = 1
  2394.       FOR j = 1 TO LENGTH
  2395.      Character$ = MID$(format$, j, 1)
  2396.      IF INSTR(".", Character$) THEN
  2397.         MID$(work$, j, 1) = Character$
  2398.      ELSE
  2399.         char$ = MID$(temp$, k, 1)
  2400.         MID$(work$, j, 1) = char$
  2401.         k = k + 1
  2402.      END IF
  2403.       NEXT j
  2404.       userNformat$ = work$
  2405.    END FUNCTION
  2406.  
  2407.    FUNCTION userSformat$ (wrk$, format$)
  2408.       work$ = wrk$
  2409.       LENGTH = LEN(format$)
  2410.       FOR j = 1 TO LENGTH
  2411.      FChr$ = MID$(format$, j, 1)
  2412.      SELECT CASE FChr$
  2413.         CASE "~", "@", "0" TO "9", "#", "*"
  2414.         CASE ELSE
  2415.            formatVALUES$ = formatVALUES$ + FChr$
  2416.      END SELECT
  2417.       NEXT j
  2418.       temp$ = work$
  2419.       work$ = STRING$(LENGTH, " ")
  2420.       k = 1
  2421.       FOR j = 1 TO LENGTH
  2422.      Character$ = MID$(format$, j, 1)
  2423.      IF INSTR(formatVALUES$, Character$) THEN
  2424.         MID$(work$, j, 1) = Character$
  2425.      ELSE
  2426.         char$ = MID$(temp$, k, 1)
  2427.         MID$(work$, j, 1) = char$
  2428.         k = k + 1
  2429.      END IF
  2430.       NEXT j
  2431.       userSformat$ = work$
  2432.    END FUNCTION
  2433.  
  2434. '
  2435.    SUB waitkey (ROW, fg, bg)
  2436.  
  2437.       CONST a$ = "Press any key to continue"
  2438.  
  2439.       GetBackground ROW, 1, ROW, 80, mb$
  2440.       c = 80 - LEN(a$)
  2441.       c = c / 2
  2442.       pnc a$, ROW, c, fg, bg
  2443.       DO
  2444.      key$ = INKEY$
  2445.       LOOP UNTIL key$ <> ""
  2446.       PutBackground ROW, 1, mb$: mb$ = ""
  2447.    END SUB
  2448.  
  2449.