home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 14 / CDACTUAL.iso / cdactual / demobin / share / program / Basic / STDLIB.ZIP / GETNUMBR.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-10-04  |  6.2 KB  |  183 lines
  1. '****************************************************************************
  2. 'Total Control Systems                                         QuickBasic 4.5
  3. '****************************************************************************
  4. '
  5. '  Program     : GETNUMBR.BAS
  6. '  Written by  : Tim Beck
  7. '  Written On  : 10-01-90
  8. '  Function    : GET NUMBER SUB ROUTINES
  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 PadS$ (Number$, Padby%, Padwith%)
  47.    DECLARE FUNCTION FreeWind% ()
  48.   
  49.    DECLARE SUB CLOSE.WINDOW (wid%)
  50.  
  51.    DECLARE SUB GETNUMBER (Hdr$, msg$, cpos%, S$, flag%)
  52.    DECLARE SUB GETNUMBER2 (Hdr$, msg1$, msg2$, cpos%, s1$, s2$, flag%)
  53.  
  54.    '------------------------------------------------------------------------
  55.    '  Gets one or two numeric strings from the user
  56.    '
  57.    '  Hdr$        = Header of Input Box
  58.    '  msg$, msg1$ = Message of First Numeric Input Line
  59.    '  msg2$       = Message of Second Input Line
  60.    '  cpos%       = Position of Cursor in First numeric Input
  61.    '  s1$         = returned numeric string 1
  62.    '  s2$         = returned numeric string 2
  63.    '  flag%       = Input Flag% (1 = OK!)
  64.  
  65.    REM $INCLUDE: 'STDCOM.INC'
  66.  
  67.    TIMER OFF    'Enables Event Trapping
  68.  
  69. '   ON ERROR GOTO ErrorTrap
  70.  
  71. ErrorTrap:
  72.  
  73. '   RESUME
  74.  
  75. SUB GETNUMBER (Hdr$, msg$, cpos%, S$, flag%) STATIC
  76.  
  77.    cpos% = cpos% - 1
  78.    IF cpos% <= 0 THEN
  79.       cpos% = 0
  80.    END IF
  81.   
  82.    flag% = 1
  83.  
  84.    Style% = Sh.Flag% + EX.Flag% + 1
  85.    edits% = 8483  '(keep contents, no letters, +-, allow INS/DEL, insert/ovrwrt, normal exit when full)
  86.    exits% = 17407 '(all function keys + ESC)
  87.  
  88.    x1% = 80 - ((LEN(msg$) + LEN(S$)) + 6)
  89.    x1% = x1% / 2
  90.    y1% = 10
  91.    x2% = x1% + (LEN(msg$) + LEN(S$)) + 6
  92.    y2% = 14
  93.  
  94.    S$ = PadS$(S$, LEN(S$), 1)
  95.  
  96.    wid% = FreeWind%
  97.    sav% = wid%                      'In case of error, wid% will be returned
  98.                                     'negative, sav restores original value
  99.    idx% = ((wid% - 1) * 2000)       'each window is allotted 2000 characters
  100.   
  101.    CALL WOPENI(x1%, y1%, x2%, y2%, Style%, S.attr%, Hdr$, w.array%(), idx%, wid%)
  102.    IF wid% <= 0 THEN
  103.       wid% = sav%
  104.    END IF
  105.    CALL WPRINTA(wid%, 2, 1, S.attr%, msg$)
  106.    CALL WLOCATE(wid%, LEN(msg$) + 2, 1)
  107.    CALL WINPUT(wid%, S$, cpos%, edits%, exits%, " 0123456789", kb%, flag%)
  108.  
  109.    S$ = PadS$(S$, LEN(S$), 1)
  110.  
  111.    CALL CLOSE.WINDOW(wid%)
  112.  
  113.    IF flag% = 1 THEN
  114.       flag% = 0
  115.    END IF
  116.  
  117. END SUB
  118.  
  119. SUB GETNUMBER2 (Hdr$, msg1$, msg2$, cpos%, s1$, s2$, flag%) STATIC
  120.  
  121.    cpos% = cpos% - 1
  122.    IF cpos% <= 0 THEN
  123.       cpos% = 0
  124.    END IF
  125.  
  126.    flag% = 1
  127.   
  128.    Style% = Sh.Flag% + EX.Flag% + 1
  129.   
  130.    edits% = 8483  '(keep contents, no letters, +-, allow INS/DEL, insert/ovrwrt, normal exit when full)
  131.    exits% = 17407 '(all function keys + ESC)
  132.   
  133.    x1% = 80 - ((LEN(msg1$) + LEN(s1$)) + 6)
  134.    x1% = x1% / 2
  135.    y1% = 9
  136.    x2% = x1% + (LEN(msg1$) + LEN(s1$)) + 6
  137.    y2% = 15
  138.  
  139.    s1$ = PadS$(s1$, LEN(s1$), 1)
  140.    s2$ = PadS$(s2$, LEN(s2$), 1)
  141.  
  142.    wid% = FreeWind%
  143.    sav% = wid%                      'In case of error, wid% will be returned
  144.                                     'negative, sav restores original value
  145.    idx% = ((wid% - 1) * 2000)       'each window is allotted 2000 characters
  146.   
  147.    CALL WOPENI(x1%, y1%, x2%, y2%, Style%, S.attr%, Hdr$, w.array%(), idx%, wid%)
  148.    IF wid% <= 0 THEN
  149.       wid% = sav%
  150.    END IF
  151.  
  152.    CALL WPRINTA(wid%, 2, 1, S.attr%, msg1$ + s1$)
  153.    CALL WPRINTA(wid%, 2, 3, S.attr%, msg2$ + s2$)
  154.  
  155.    DO
  156.  
  157.       flag% = 1                              'Initialize
  158.       CALL WLOCATE(wid%, LEN(msg1$) + 2, 1)
  159.       CALL WINPUT(wid%, s1$, cpos%, edits%, exits%, " 0123456789", kb%, flag%)
  160.       IF kb% = Escape% OR kb% = F.9% THEN
  161.          EXIT SUB
  162.       ELSE
  163.          s1$ = PadS$(s1$, LEN(s1$), 1)
  164.          CALL WPRINTA(wid%, 2, 1, S.attr%, msg1$ + s1$)
  165.       END IF
  166.  
  167.       flag% = 1                              'Initialize
  168.       CALL WLOCATE(wid%, LEN(msg2$) + 2, 3)
  169.       CALL WINPUT(wid%, s2$, 0, edits%, exits%, " 0123456789", kb%, flag%)
  170.       s2$ = PadS$(s2$, LEN(s2$), 1)
  171.       CALL WPRINTA(wid%, 2, 3, S.attr%, msg1$ + s2$)
  172.  
  173.    LOOP UNTIL flag% = 1
  174.  
  175.    CALL CLOSE.WINDOW(wid%)
  176.  
  177.    IF flag% = 1 THEN
  178.       flag% = 0
  179.    END IF
  180.  
  181. END SUB
  182.  
  183.