home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 14 / CDACTUAL.iso / cdactual / demobin / share / program / Basic / STDLIB.ZIP / GSTRING.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-10-04  |  11.4 KB  |  359 lines
  1. '****************************************************************************
  2. 'Total Control Systems                                         QuickBasic 4.5
  3. '****************************************************************************
  4. '
  5. '  Program     : GSTRING.BAS
  6. '  Written by  : Tim Beck
  7. '  Written On  : 10-01-90
  8. '  Function    : GET STRING INPUT
  9. '
  10. '****************************************************************************
  11. '  This program and those associated with it were written for use with Quick-
  12. '  Windows Advanced (Version 1.5+).  Possesion of this program entitles you
  13. '  to certain priviliges.  They are:
  14. '
  15. '     1. You may compile, use, or modify this program in any way you choose
  16. '        provided you do not sell or give away the source code to this prog-
  17. '        ram or any of it's companions to anyone for any reason.  You may,
  18. '        however, sell the resulting executable program as you see fit.
  19. '
  20. '     2. You may modify, enhance or change these programs as you see fit. I
  21. '        as that you keep a copy of the original code and that you notify
  22. '        me of any improvements you make.  I like to think that the code is
  23. '        bug free and cannot be improved upon, but I'm sure someone will
  24. '        find a way to make it better.  If it's you, I'm looking forward to
  25. '        seeing your changes.  I can be reached at:
  26. '
  27. '              Tim Beck                      Tim Beck (C/O Debbie Beck)
  28. '              19419 Franz Road              8030 Fairchild Avenue
  29. '              Houston, Texas  77084         Canoga Park, California 91306
  30. '              (713) 639-3079                (818) 998-0588
  31. '
  32. '     3. This code has been tested and re-tested in a variety of applications
  33. '        and although I have not found any bugs, doesn't mean none exist. So,
  34. '        this program along with it's companions comes with NO WARRANTY,
  35. '        either expressed or implied.  I'm sorry if there are problems, but
  36. '        I can't be responsible for your work.  I've tried to provide a safe
  37. '        and efficient programming enviroment and I hope you find it helpful
  38. '        for you.  I do, however, need to cover my butt!
  39. '
  40. '  I have enjoyed creating this library of programs and have found them to be
  41. '  a great time saver.  I hope you agree.
  42. '
  43. '                                                            Tim Beck //
  44. '
  45. '****************************************************************************
  46.    DECLARE FUNCTION FreeWind% ()
  47.    DECLARE SUB CLOSE.WINDOW (wid%)
  48.    DECLARE SUB GET.INPUT (Row%, Col%, C.pos%, C.type%, AR.Flag%, C.Flag%, blank%, I.Color%, Format$, Linp$, M.len%, E.Flag%, kb%)
  49.    DECLARE SUB MAXWID (M.Item%, msg$(), max.wid%)
  50.  
  51.    DECLARE SUB GETSTRING (x1%, y1%, Hgt%, Hdr$, msg$, cpos%, accept$, Format$, S$, flag%)
  52.    DECLARE SUB GETSTRINGS (x1%, y1%, Hgt%, Hdr$, msgs$(), msgs%, cpos%, accept$(), Format$(), fields$(), flag%)
  53.  
  54.    '------------------------------------------------------------------------
  55.    '  Gets string input from the user
  56.    '
  57.    '  x1%, y1%          = Top left column and row of the Input Box
  58.    '  Hgt%              = Height of the Input Box
  59.    '  Hdr$              = Header of Input Box
  60.    '  msg$, msgs$()     = Message(s) of Input Line
  61.    '  msgs%             = Number of Elements of msgs$() array (GETSTRINGS only)
  62.    '  cpos%             = Position of Cursor in First Input item
  63.    '  accept$, accept$()= Characters to accept (ie only accept "ABCDEF")
  64.    '  Format$, Format$()= Input string Format(s) (see GET.INPUT)
  65.    '  s$, fields$()     = returned Input string(s)
  66.    '  flag%             = Input Flag% (0 = OK!)
  67.    '
  68.    '
  69.    '  GETSTRING and GETSTRINGS prompt the user for (optionally formatted)
  70.    '  string input from within a window (style is 1 + SH.Flag% + EX.Flag%).
  71.    '  GETSTRINGS will prompt for a number of items, with each item being
  72.    '  separated by a blank line.  If there are to many items to fit vert-
  73.    '  ically, GETSTRINGS will attempt to make the box Half-Height.  That
  74.    '  is, items are set next to each other like so:
  75.    '
  76.    '           item 1   item 2
  77.    '
  78.    '           item 3   item 4
  79.   
  80.  
  81.    REM $INCLUDE: 'STDCOM.INC'
  82.  
  83.    TIMER OFF    'Enables Event Trapping
  84.  
  85. '  ON ERROR GOTO ErrorTrap
  86.  
  87. ErrorTrap:
  88.  
  89. '  RESUME
  90.  
  91. SUB GETSTRING (x1%, y1%, Hgt%, Hdr$, msg$, cpos%, accept$, Format$, S$, flag%) STATIC
  92.   
  93.    flag% = 1
  94.   
  95.    Style% = Sh.Flag% + EX.Flag% + 1
  96.  
  97.    edits% = 8449  '(keep contents, any character, allow INS/DEL, normal exit when full)
  98.    exits% = 17407 '(all function keys + ESC)
  99.   
  100.    IF x1% = 0 THEN
  101.       x1% = 80 - ((LEN(msg$) + LEN(S$)) + 6)
  102.       x1% = x1% / 2
  103.    END IF
  104.    IF y1% = 0 THEN
  105.       y1% = 10
  106.    END IF
  107.    x2% = x1% + (LEN(msg$) + LEN(S$)) + 6
  108.    IF Hgt% = 0 THEN
  109.       y2% = y1% + 4
  110.       pp% = 1
  111.    ELSE
  112.       y2% = y1% + Hgt%
  113.       pp% = (Hgt% - 2) / 2
  114.    END IF
  115.  
  116.    C.Flag% = 0
  117.    FOR C% = 1 TO LEN(accept$)
  118.       IF ASC(MID$(accept$, C%, 1)) >= 65 AND ASC(MID$(accept$, C%, 1)) <= 90 THEN
  119.          C.Flag% = 1
  120.       ELSEIF ASC(MID$(accept$, C%, 1)) >= 97 THEN
  121.          C.Flag% = 0
  122.          EXIT FOR
  123.       END IF
  124.    NEXT C%
  125.  
  126.    wid% = FreeWind%
  127.    sav% = wid%                      'In case of error, wid% will be returned
  128.                                     'negative, sav restores original value
  129.    idx% = ((wid% - 1) * 2000)       'each window is allotted 2000 characters
  130.  
  131.    CALL WOPENI(x1%, y1%, x2%, y2%, Style%, S.attr%, Hdr$, w.array%(), idx%, wid%)
  132.    IF wid% <= 0 THEN
  133.       wid% = sav%
  134.    END IF
  135.  
  136.    CALL WPRINTA(wid%, 2, pp%, S.attr%, msg$)
  137.    CALL WTITLE(wid%, 1, S.attr%, Hdr$)
  138.    IF LEN(Format$) OR F% = 2 THEN
  139.       IF F% = 2 THEN
  140.          M.pwd% = 1
  141.       END IF
  142.       LOCATE y1% + pp% + 1, x1% + LEN(msg$) + 3
  143.       DO
  144.          accept% = -1
  145.          CALL GET.INPUT(y1% + pp% + 1, x1% + LEN(msg$) + 3, cpos%, 2, 1, C.Flag%, 0, 1, Format$, S$, 0, F%, kb%)
  146.          IF LEN(accept$) THEN
  147.             FOR C% = 1 TO LEN(S$)
  148.                IF INSTR(accept$, MID$(S$, C%, 1)) = 0 THEN
  149.                   IF MID$(S$, C%, 1) <> MID$(Format$, C%, 1) THEN
  150.                      accept% = 0
  151.                      EXIT FOR
  152.                   END IF
  153.                END IF
  154.             NEXT C%
  155.          END IF
  156.       LOOP UNTIL accept% OR F%
  157.    ELSE
  158.       cpos% = cpos% - 1
  159.       IF cpos% < 0 THEN
  160.          cpos% = 0
  161.       END IF
  162.       F% = 1
  163.       edits% = edits% + (32 * C.Flag%)
  164.       CALL WLOCATE(wid%, LEN(msg$) + 2, pp%)
  165.       CALL WINPUT(wid%, S$, cpos%, edits%, exits%, accept$, kb%, F%)
  166.       IF F% = 1 THEN
  167.          F% = 0
  168.       ELSE
  169.          F% = 1
  170.       END IF
  171.    END IF
  172.    CALL CLOSE.WINDOW(wid%)
  173.  
  174.    flag% = F%
  175.  
  176. END SUB
  177.  
  178. SUB GETSTRINGS (x1%, y1%, Hgt%, Hdr$, msgs$(), msgs%, cpos%, accept$(), Format$(), fields$(), flag%) STATIC
  179.  
  180.    pp% = 1
  181.    flag% = 1
  182.    Half.Height% = 0
  183.  
  184.    Style% = Sh.Flag% + EX.Flag% + 1
  185.  
  186.    edits% = 8449  '(keep contents, any character, allow INS/DEL, normal exit when full)
  187.    exits% = 17407 '(all function keys + ESC)
  188.  
  189.    IF y1% = 0 THEN
  190.       y1% = 10 - (msgs% / 2)
  191.    END IF
  192.   
  193.    IF Hgt% = 0 THEN
  194.       y2% = y1% + 2 + (msgs% * 2)
  195.       IF y2% > 22 THEN
  196.          Half.Height% = -1
  197.          y2% = y1% + 2 + msgs%
  198.       END IF
  199.    ELSEIF Hgt% > msgs% THEN
  200.       y2% = y1% + Hgt%
  201.    ELSEIF Hgt% > (msgs% / 2) THEN
  202.       Half.Height% = -1
  203.       y2% = y1% + Hgt%
  204.    END IF
  205.  
  206.    IF y1% < 1 OR y2% > 22 THEN
  207.       EXIT SUB
  208.    END IF
  209.  
  210.    CALL MAXWID(msgs%, msgs$(), Len.msg%)
  211.    CALL MAXWID(msgs%, fields$(), Len.fld%)
  212.    
  213.    IF Half.Height% THEN
  214.       Len.Box% = (2 * (Len.msg% + Len.fld%)) + 7
  215.    ELSE
  216.       Len.Box% = (Len.msg% + Len.fld%) + 5
  217.    END IF
  218.  
  219.    IF Len.Box% < LEN(Hdr$) + 6 THEN
  220.       Len.Box% = LEN(Hdr$) + 6
  221.    END IF
  222.  
  223.    IF x1% = 0 THEN
  224.       x1% = 80 - Len.Box%
  225.       x1% = x1% / 2
  226.    END IF
  227.   
  228.    x2% = x1% + Len.Box%
  229.  
  230.    IF x1% < 1 OR x2% > 79 THEN
  231.       EXIT SUB
  232.    END IF
  233.  
  234.    wid% = FreeWind%
  235.    sav% = wid%                      'In case of error, wid% will be returned
  236.                                     'negative, sav restores original value
  237.    idx% = ((wid% - 1) * 2000)       'each window is allotted 2000 characters
  238.  
  239.    CALL WOPENI(x1%, y1%, x2%, y2%, Style%, S.attr%, Hdr$, w.array%(), idx%, wid%)
  240.    IF wid% <= 0 THEN
  241.       wid% = sav%
  242.    END IF
  243.  
  244.    CALL WTITLE(wid%, 1, S.attr%, Hdr$)
  245.  
  246.    FOR fld% = 1 TO msgs%
  247.   
  248.       CALL WPRINTA(wid%, 2, pp%, S.attr%, msgs$(fld%))
  249.       CALL WPRINTA(wid%, 2 + Len.msg%, pp%, DE.attr%, fields$(fld%))
  250.       IF Half.Height% THEN
  251.          fld% = fld% + 1
  252.          CALL WPRINTA(wid%, 2 + Len.msg% + Len.fld% + 2, pp%, S.attr%, msgs$(fld%))
  253.          CALL WPRINTA(wid%, 2 + Len.msg% + Len.fld% + 2 + Len.msg%, pp%, DE.attr%, fields$(fld%))
  254.       END IF
  255.       pp% = pp% + 2
  256.  
  257.    NEXT fld%
  258.   
  259.    pp% = 1
  260.    fld% = 1
  261.  
  262.    DO
  263.   
  264.       C.Flag% = 0
  265.       accept$ = accept$(fld%)
  266.       Format$ = Format$(fld%)
  267.       field$ = fields$(fld%)
  268.  
  269.       FOR C% = 1 TO LEN(accept$)
  270.          IF ASC(MID$(accept$, C%, 1)) >= 65 AND ASC(MID$(accept$, C%, 1)) <= 90 THEN
  271.             C.Flag% = 1
  272.          ELSEIF ASC(MID$(accept$, C%, 1)) >= 97 THEN
  273.             C.Flag% = 0
  274.             EXIT FOR
  275.          END IF
  276.       NEXT C%
  277.  
  278.       IF LEN(Format$) OR F% = 2 THEN
  279.          IF F% = 2 THEN
  280.             M.pwd% = 1
  281.          END IF
  282.          Row% = y1% + pp% + 1
  283.          IF fld% MOD 2 = 0 AND Half.Height% THEN
  284.             Col% = x1% + (2 * Len.msg%) + 5 + Len.fld%
  285.          ELSE
  286.             Col% = x1% + Len.msg% + 3
  287.          END IF
  288.          DO
  289.             accept% = -1
  290.             CALL GET.INPUT(Row%, Col%, cpos%, 2, 1, C.Flag%, 0, 1, Format$, field$, LEN(field$), F%, kb%)
  291.             cpos% = 0
  292.             fields$(fld%) = field$
  293.             IF kb% = Up.Arrow% THEN
  294.                fld% = fld% - 2
  295.                pp% = pp% - (2 + (2 * ABS(NOT Half.Height%)))
  296.                IF fld% < 0 THEN
  297.                   F% = 1
  298.                   EXIT DO
  299.                ELSE
  300.                   F% = 0
  301.                END IF
  302.             ELSEIF kb% = F.9% THEN
  303.                F% = 1
  304.                EXIT DO
  305.             ELSEIF LEN(accept$) THEN
  306.                FOR C% = 1 TO LEN(field$)
  307.                   IF INSTR(accept$, MID$(field$, C%, 1)) = 0 THEN
  308.                      IF MID$(field$, C%, 1) <> MID$(Format$, C%, 1) THEN
  309.                         accept% = 0
  310.                         EXIT FOR
  311.                      END IF
  312.                   END IF
  313.                NEXT C%
  314.             END IF
  315.          LOOP UNTIL accept% OR F%
  316.       ELSE
  317.          cpos% = cpos% - 1
  318.          IF cpos% < 0 THEN
  319.             cpos% = 0
  320.          END IF
  321.          F% = 1
  322.          edits% = edits% + (32 * C.Flag%)
  323.          IF fld% MOD 2 = 0 AND Half.Height% THEN
  324.             CALL WLOCATE(wid%, 2 + Len.msg% + Len.fld% + Len.msg% + 2, pp%)
  325.          ELSE
  326.             CALL WLOCATE(wid%, 2 + Len.msg%, pp%)
  327.          END IF
  328.          CALL WINPUT(wid%, field$, cpos%, edits%, exits%, accept$, kb%, F%)
  329.          cpos% = 0
  330.          fields$(fld%) = field$
  331.          IF kb% = Up.Arrow% THEN
  332.             fld% = fld% - 2
  333.             pp% = pp% - (2 + (2 * ABS(NOT Half.Height%)))
  334.             IF fld% < 0 THEN
  335.                F% = 1
  336.                EXIT DO
  337.             END IF
  338.          END IF
  339.          IF F% = 1 THEN
  340.             F% = 0
  341.          ELSE
  342.             F% = 1
  343.          END IF
  344.       END IF
  345.  
  346.       fld% = fld% + 1
  347.       IF NOT (fld% MOD 2 = 0 AND Half.Height%) THEN
  348.          pp% = pp% + 2
  349.       END IF
  350.   
  351.    LOOP UNTIL fld% > msgs% OR F% = 1 OR kb% = F.10%
  352.  
  353.    CALL CLOSE.WINDOW(wid%)
  354.  
  355.    flag% = F%
  356.  
  357. END SUB
  358.  
  359.