home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / BASIC / QINP73.ZIP / QINP73.BAS next >
Encoding:
BASIC Source File  |  1990-06-03  |  54.7 KB  |  1,840 lines
  1. '           Microsoft BASIC 7.0, Professional Development System
  2. '              Copyright (C) 1987-1989, Microsoft Corporation
  3. '
  4. '           Microsoft QBX 7.0, Professional Development System
  5. '              Copyright (C) 1987-1989, Microsoft Corporation
  6. '
  7. '                    Raymond E Dixon
  8. '                    5815 Buckley Dr.
  9. '                    Jacksonville, Fl. 32244
  10. '
  11. '                    (904) 778-4048
  12. '                    (904) 772-0329
  13. '
  14. '    I think the only routine that won't work with QB45 is "SLEEP()"(removed)
  15. '      which is a QBX function , replace a loop for QB45.
  16. '    I started all subs with Q so not to conflict with other subs
  17. '      when I need to load and move to my programs.
  18. ' ALL the main code is for testing the sub.
  19. '
  20. ' UPDATES:   and a few comments from aurthor.
  21. '
  22. ' started 05/12/90
  23. ' added numeric input 5/30/90 to handle decimal, neg and real numbers
  24. ' in numericinput only numbers and decimal allowed in format
  25. ' speeded up input routine by removing unessary code.
  26. ' removed SLEEP()
  27. ' fixed a few bugs 06/03/90
  28. ' after many hours work seems to function the way I had hope for.
  29.  
  30. '*************** Declarations and definitions begin here ********************
  31.    DEFINT A-Z  'Resets the default data type from single precision to integer
  32.  
  33.    DECLARE FUNCTION Qformateditnum$ (work$, format$, ExitCode%, UPflag%, PGUPflag%, DNflag%, PGDNflag%, RETflag%, TABflag%, ESCflag%)
  34.    DECLARE FUNCTION Qformateditstr$ (work$, format$, caseflag%, ExitCode%, UPflag%, PGUPflag%, DNflag%, PGDNflag%, RETflag%, TABflag%, ESCflag%)
  35.    DECLARE FUNCTION Qremovechar$ (userstring$, skip$)
  36.    DECLARE FUNCTION Qremoveformat$ (instring$, format$)
  37.    DECLARE FUNCTION Quserformat$ (inputstring$, format$)
  38.    DECLARE SUB Qdrawscreen ()
  39.    DECLARE SUB Qmessage (msg$, row%)
  40.    DECLARE SUB Qsglbox (scol1%, srow1%, ecol1%, erow1%)
  41.    DECLARE SUB Qdblbox (leftcol%, leftrow%, rightcol%, rightrow%)
  42.    DECLARE SUB QformatDEC (a$, beforeDEC%, afterdec%)
  43.    DECLARE SUB Qclreol ()
  44.    DECLARE SUB Qclrscrn (startline%, endline%, startcol%, endcol%)
  45.  
  46. ' Define names similar to keyboard names with their equivalent key codes.
  47.  
  48.    CONST SPACE = 32, ESC = 27, enter = 13, TABKEY = 9
  49.    CONST DOWN = 80, UP = 72, LEFT = 75, RIGHT = 77
  50.    CONST HOME = 71, ENDK = 79, PGDN = 81, PGUP = 73
  51.    CONST INS = 82, DEL = 83, NULL = 0
  52.    CONST CTRLD = 4, CTRLG = 7, CTRLH = 8, CTRLS = 19, CTRLV = 22
  53.  
  54. ' Define English names for color-specification numbers. Add BRIGHT to
  55. ' any color to get bright version.
  56.  
  57.    CONST BLACK = 0, blue = 1, GREEN = 2, CYAN = 3, RED = 4, MAGENTA = 5
  58.    CONST YELLOW = 6, WHITE = 7, BRIGHT = 8
  59.  
  60. ' Assign colors to different kinds of text. By changing the color assigned,
  61. ' you can change the color of the display. The initial colors are
  62. ' chosen because they work for color or black-and-white displays.
  63. ' Codes for normal and highlight
  64.  
  65.    HILITE = WHITE + BRIGHT
  66.    CONST BACKGROUND = blue
  67.    CONST normal = WHITE + BRIGHT
  68.  
  69. ' Miscellaneous symbolic constants
  70.  
  71.    CONST False = 0, True = 1
  72.    CONST CURSORON = 1, CURSOROFF = 0
  73.  
  74.    'set edit colors
  75.    'Editbackground = RED
  76.    'Editforeground = WHITE + BRIGHT
  77.  
  78.    'set edit to reverse
  79.    editbackground = normal
  80.    editforeground = blue
  81.  
  82. '*************** Declarations and definitions end here ********************
  83.  
  84.    COLOR HILITE, blue
  85.    CLS
  86.    Qdrawscreen
  87.    Qclrscrn 4, 20, 2, 78
  88.    msg$ = "ESC restores CTRL-E Clears, all other edit keys function normal"
  89.    Qmessage msg$, 3
  90.  
  91. start:
  92. '
  93. ' comment out the format$ that are not being used and a instring to match
  94. ' except for prompt message.
  95. ' format$  can not be a null
  96. ' string passed maybe null "" or any basic string
  97. ' there are so many formats that I only listed a few, just try yours
  98. 'GOTO num
  99. '******************************************************************
  100.    instring$ = "887649889"
  101.    msg1$ = ": string returned unformated"
  102.    format$ = "(999)-(99)-(9999) SS number"
  103.    msg2$ = ": enter data at specified position"
  104.    GOSUB teststring
  105.  
  106. '******************************************************************
  107.    instring$ = "409"
  108.    msg1$ = ": enter at specified area using string input"
  109.    format$ = "before:>999<:after"
  110.    msg2$ = ": before and after prompts"
  111.    GOSUB teststring
  112.  
  113. '*******************************************************************
  114.    instring$ = "123456789"
  115.    msg1$ = ": numeric input are right justified"
  116.    format$ = "9999999"
  117.    msg2$ = ": if longer than format left characters are lost"
  118.    GOSUB testnumeric
  119.  
  120. '*******************************************************************
  121.    instring$ = "123.4500"
  122.    msg1$ = ": decimal numbers are aligned"
  123.    format$ = "99999.99"
  124.    msg2$ = ": for numeric input all numbers are input right to left"
  125.    GOSUB testnumeric
  126.  
  127. '*******************************************************************
  128.    instring$ = "44.00"
  129.    msg1$ = ": instring$ maybe upto 80 char"
  130.    format$ = "99999.999"
  131.    msg2$ = ": format maybe different decimal pos"
  132.    GOSUB testnumeric
  133.  
  134. '***********************************************
  135.    instring$ = "7770329"
  136.    msg1$ = ": seven digit phone numbers"
  137.    format$ = " 999-9999  seven digit phone"      '  7 digit phone
  138.    msg2$ = ": allmost any format using string input"
  139.    GOSUB teststring
  140.  
  141. '***********************************************
  142.    instring$ = "9047784048"    ' 10 digit phone
  143.    msg1$ = ": ten digit phone numbers"
  144.  
  145.    format$ = "(999) 999-9999"
  146.    msg2$ = ": allmost any format"
  147.    GOSUB teststring
  148.  
  149.    msg1$ = ": ten digit phone numbers"
  150.  
  151. '           with user prompt
  152.    format$ = "Area Code: (999) Phone: 999-9999"
  153.    msg2$ = ": allmost any format, even user prompt "
  154.    GOSUB teststring
  155.  
  156. '********************************************************
  157.    instring$ = Qremovechar(LEFT$(DATE$, 6), "-") + RIGHT$(DATE$, 2)
  158. '  instring="040146"       ' date input
  159.    msg1$ = ": date formated input"
  160.  
  161.    format$ = " 19/39/99 "  'mask for month/day/year
  162.    msg2$ = ": with limited entry"
  163.    GOSUB teststring
  164.  
  165. '***********************************************
  166.    instring$ = "M"
  167.    msg1$ = ": maybe preset to Male or Female"
  168.    format$ = "Enter Male or Female ? (M/F):|"   '   one char M/F
  169.    msg2$ = ": only MF allowed"
  170.    GOSUB teststring
  171. '********************************************************
  172.    instring$ = "A124444"
  173.    msg1$ = ": account numbers"
  174.  
  175.    format$ = "ACC NO: @99-9999" 'first char is alpha only ,rest numeric
  176.    msg2$ = ": any format with alpha only first digit"
  177.    GOSUB teststring
  178.  
  179. '********************************************************
  180. ' for fixed length strings or user type
  181.  
  182.    instring$ = "raymond e dixon"
  183.    msg1$ = ": may force caps, upper, lower or any case "
  184.    'format$ = STRING$(LEN(instring$), "@")
  185.    msg2$ = ": alpha input only, alphanumeric or numeric only"
  186.  
  187.    format$ = ">@@@@@@@@@@@@@@@@@@@@@@@<"
  188.    GOSUB teststring
  189.  
  190. '********************************************************
  191.    instring$ = ""
  192.    msg1$ = ": force enterkey or exitkey only, for msg display "
  193.    format$ = " Press ENTER key to Continue ~"   '(~) requires enter to be pressed
  194.    msg2$ = ": any single line message can be displayed"
  195.    GOSUB teststring
  196. '********************************************************
  197.  
  198.    msg1$ = ""
  199.  
  200. redosformat:
  201.    msg2$ = " Enter Your Format String (no quotes): "
  202.    format$ = msg2$ + STRING$(25, "#")
  203.  
  204. Qclrscrn 4, 20, 2, 78
  205. LOCATE 4, 4
  206. PRINT "Formats Allowed:";
  207. LOCATE 5, 5
  208. PRINT CHR$(34) + "99" + CHR$(34) + "             ' numbers only  < (99 max) each digit = to max value";
  209. LOCATE 6, 5
  210. PRINT CHR$(34) + "19" + CHR$(34) + "             ' (19) is max value";
  211. LOCATE 7, 5
  212. PRINT CHR$(34) + "999-99-9999    SS number" + CHR$(34);
  213. LOCATE 8, 5
  214. PRINT CHR$(34) + "999-9999; " + CHR$(34) + "     ' 7 digit phone";
  215. LOCATE 9, 5
  216. PRINT CHR$(34) + "(999) 999-9999" + CHR$(34) + " ' 10 digit phone";
  217. LOCATE 10, 5
  218. PRINT CHR$(34) + "19/39/99" + CHR$(34) + "       ' date format";
  219. LOCATE 11, 5
  220. PRINT CHR$(34) + "########" + CHR$(34) + "       '# alphanumeric set for 8 characters maybe more or less";
  221. LOCATE 12, 5
  222. PRINT CHR$(34) + "@@@@@@@@" + CHR$(34) + "       '@ alpha only   same as above";
  223. LOCATE 13, 5
  224. PRINT CHR$(34) + "Y/N:*" + CHR$(34) + "          '* force YN answer.";
  225. LOCATE 14, 5
  226. PRINT CHR$(34) + "M/F:|" + CHR$(34) + "          '| force MF answer.";
  227. LOCATE 15, 5
  228. PRINT CHR$(34) + "MESSAGE~" + CHR$(34) + "       '~ force enter key or other exitkey for prompts .";
  229. LOCATE 16, 5
  230. PRINT "maybe any format you can create in a basic string except #@~*|0123456789";
  231. LOCATE 17, 5
  232. PRINT "may not be used in prompt,  you can even include a message if you like.";
  233.  
  234. LOCATE 18, 5
  235. PRINT "      " + CHR$(34) + "Test Data: 99" + CHR$(34) + " <- this format will print";
  236. LOCATE 19, 5
  237. PRINT "       Test Data: your value passed";
  238. LOCATE 20, 5
  239. PRINT "                 in the the length of 2 Setting max value to 99.";
  240. '
  241.  
  242.     instring$ = ""
  243.     LOCATE 22, 3
  244.  
  245.     instring$ = Qformateditstr(instring$, format$, 1, ExitCode, 0, 0, 0, 0, 1, 1, 0)
  246.  
  247.     'test user input
  248.     IF LEN(instring$) THEN
  249.      FOR cpos = 1 TO LEN(instring$)
  250.        ' see if input is valid
  251.        IF INSTR("#@~0123456789*", MID$(instring$, cpos, 1)) THEN
  252.           test$ = MID$(instring$, cpos, 1)
  253.           'get valid char
  254.           EXIT FOR
  255.        END IF
  256.      NEXT cpos
  257.  
  258.      ELSE
  259.       'user press return
  260.       GOTO redosformat
  261.      END IF
  262.  
  263.      IF LEN(test$) > 0 THEN ' user format ok
  264.       format$ = instring$
  265.       instring$ = ""
  266.      ELSE
  267.       GOTO redosformat
  268.      END IF
  269. '
  270. ' test user format
  271. '
  272.    msg1$ = ""
  273.    instring$ = ""
  274.    msg2$ = ": Test your Format$ "
  275.  
  276.    GOSUB teststring
  277. '***********************************************
  278.    instring$ = "Y"
  279.    msg1$ = ": maybe preset to Yes or No"
  280.    format$ = "TEST another STRING format? (Y/N):*"   '   one char y/n
  281.    msg2$ = ": only YN allowed"
  282.    GOSUB teststring
  283.  
  284.    IF instring$ = "Y" THEN
  285.    GOTO redosformat
  286.    END IF
  287. '*****************************************************************************
  288.    msg1$ = ""
  289.  
  290. redonformat:
  291.    msg2$ = " Enter Your Format String (no quotes): "
  292.    format$ = msg2$ + STRING$(25, "#")
  293.  
  294. Qclrscrn 4, 20, 2, 78
  295.    LOCATE 2, 28
  296.    PRINT "TEST QFORMATEDITNUM";
  297.  
  298. LOCATE 6, 5
  299. PRINT "Formats Allowed:";
  300. LOCATE 7, 5
  301. PRINT CHR$(34) + "99" + CHR$(34) + "          ' numbers only  < (99 max) each digit = to max value";
  302. LOCATE 8, 5
  303. PRINT CHR$(34) + "19" + CHR$(34) + "          ' (19) is max value";
  304. LOCATE 9, 5
  305. PRINT CHR$(34) + "9999999.99" + CHR$(34) + "  ' decimal may be any position;"
  306. LOCATE 10, 5
  307. PRINT CHR$(34) + "999.9999" + CHR$(34);
  308. LOCATE 11, 5
  309. PRINT "may not use prompt or messages in numeric input.";
  310. LOCATE 12, 5
  311. PRINT "remember numbers are input right to left ."
  312.  
  313.     instring$ = ""
  314.     LOCATE 22, 3
  315.  
  316.     instring$ = Qformateditstr(instring$, format$, 1, ExitCode, 0, 0, 0, 0, 1, 1, 0)
  317.  
  318.     'test user input
  319.     IF LEN(instring$) THEN
  320.      FOR cpos = 1 TO LEN(instring$)
  321.        ' see if input is valid
  322.        IF INSTR("#@~0123456789*", MID$(instring$, cpos, 1)) THEN
  323.           test$ = MID$(instring$, cpos, 1)
  324.           'get valid char
  325.           EXIT FOR
  326.        END IF
  327.      NEXT cpos
  328.  
  329.      ELSE
  330.       'user press return
  331.       GOTO redonformat
  332.      END IF
  333.  
  334.      IF LEN(test$) > 0 THEN ' user format ok
  335.       format$ = instring$
  336.       instring$ = ""
  337.      ELSE
  338.       GOTO redonformat
  339.      END IF
  340. '
  341. ' test user format
  342. '
  343.    msg1$ = ""
  344.    instring$ = ""
  345.    msg2$ = ": Test your NUMERIC Format$ "
  346.  
  347.    GOSUB testnumeric
  348. '***********************************************
  349.    instring$ = "Y"
  350.    msg1$ = ": maybe preset to Yes or No"
  351.    format$ = "TEST another NUMERIC format? (Y/N):*"   '   one char y/n
  352.    msg2$ = ": only YN allowed"
  353.    GOSUB teststring
  354.  
  355.    IF instring$ = "Y" THEN
  356.    GOTO redonformat
  357.    END IF
  358.    GOTO start
  359. '*****************************************************************************
  360. teststring:    ' this routine test formateditstr sub
  361. '*****************************************************************************
  362.    Qclrscrn 4, 20, 2, 78
  363.    LOCATE 2, 28
  364.    PRINT "TEST QFORMATEDITSTR";
  365.    msg$ = "Press ENTER key to Continue (TAB to exit)"
  366.    Qmessage msg$, 22
  367.  
  368.    LOCATE 6, 3
  369.    PRINT "User String$ = "; CHR$(34) + instring$ + CHR$(34);
  370.    LOCATE 7, 16
  371.    PRINT msg1$;
  372.    LOCATE 8, 3
  373.    PRINT "User format$ = "; CHR$(34) + format$ + CHR$(34);
  374.    LOCATE 9, 16
  375.    PRINT msg2$;
  376.    LOCATE 11, 3
  377.    PRINT "Test Qformateditstr : ";
  378.    ExitCode = 0  'returns 1 to 7  if flag set   see sub for details
  379.    UPflag = 0  'True OR False  1 set for exitkey
  380.    PUPflag = 0  'True OR False  2  ""
  381.    DNflag = 0  'True OR False  3  ""
  382.    PDNflag = 0  'True OR False  4  ""
  383.    RTflag = 1  'True OR False  5  ""   return key exit program
  384.    TABflag = 1  'True OR False  6  ""   tab key loops agian after pause
  385.    ESCflag = 0  'True OR False  7  ""
  386.    caseflag = 1
  387.    scol1 = POS(0) + 1: srow1 = 10: ecol1 = LEN(format$) + POS(0) + 2: erow1 = 12
  388.  
  389.    Qsglbox scol1, srow1, ecol1, erow1
  390. '
  391.    LOCATE 11, scol1 + 1
  392.  
  393.    instring$ = Qformateditstr(instring$, format$, caseflag, ExitCode, UPflag, PUPflag, DNflag, PDNflag, RTflag, TABflag, ESCflag)
  394. '
  395.    LOCATE 13, 8
  396.    PRINT "Length of string: ";
  397.    PRINT LEN(instring$);
  398.    LOCATE 14, 8
  399.    PRINT "String as returned: ";
  400.    PRINT instring$;
  401.  
  402. 'use as statement
  403. '   PRINT qremovechar$(instring$, " ")
  404. 'use as function
  405. '   instring$ = qremovechar$(instring$, " ")
  406.  
  407. ' remember if you pass string as parameter userformat modifies the string.
  408. ' if you  pass as value it won't change.
  409. '     (string$) passed as value.
  410. '      string$  passed as address.
  411. ' !! Quserformat alters string if passed as address !!
  412. '    you can use removeformat to change it back.
  413. '    instring$ = qremoveformat$(instring$, format$)
  414.  
  415.    LOCATE 16, 8
  416.    PRINT "User formatted string "; Quserformat$((instring$), format$);
  417.  
  418.    LOCATE 17, 8
  419.    PRINT "ExitCode : ";
  420.    PRINT ExitCode%;
  421.  
  422. '       set flags TRUE to enable  exit on key
  423. '       FALSE on entry Disables key exit
  424. '       UPflag     = True  ,exitcode =  1
  425. '       PGUPflag   = True  ,exitcode =  2
  426. '       DNflag     = True  ,exitcode =  3
  427. '       PGDNflag   = True  ,exitcode =  4
  428. '       RETflag    = True  ,exitcode =  5
  429. '       TABflag    = True  ,exitcode =  6
  430. '       ESCflag    = True  ,exitcode =  7
  431.  
  432.    SELECT CASE ExitCode%
  433.       CASE 1  'what to do if uparrow key exit
  434.               'could be
  435.               'GOTO previous entry
  436.       CASE 2  'what to do if pageup key exit
  437.       CASE 3  'what to do if downarrow key exit
  438.               'could be
  439.               'GOTO next entry
  440.       CASE 4  'what to do if pagedown key exit
  441.       CASE 5  'what to do if enter key exit
  442.               'could be accept entry
  443.               msg$ = "Anykey to Continue"
  444.               Qmessage msg$, 22
  445.  
  446. '  Wait until there's a character
  447. '
  448.          choice$ = ""
  449.          WHILE choice$ = ""
  450.             choice$ = INKEY$
  451.          WEND
  452.  
  453. 'to be changed to a loop.
  454.          
  455.          msg$ = "ESC restores CTRL-E Clears, all other edit keys function normal"
  456.          Qmessage msg$, 3
  457.          RETURN
  458.       CASE 6  'what to do if tab key exit
  459.               'could be return to menu
  460.          GOTO ENDPROG
  461.       CASE 7  'what to do if esc key exit
  462.               'string restored
  463.    END SELECT
  464. ENDPROG:
  465.    COLOR WHITE, BLACK
  466.    CLS
  467.    END
  468. '****************************************************************************
  469. testnumeric:   ' code below is for testing numeric input routine
  470. '****************************************************************************
  471.  
  472.    Qclrscrn 4, 20, 2, 78
  473.    LOCATE 2, 28
  474.    PRINT "TEST QFORMATEDITNUM"
  475.    
  476.    msg$ = "Press ENTER key to Continue (TAB to exit)"
  477.    Qmessage msg$, 22
  478.  
  479.    LOCATE 6, 3
  480.    PRINT "User String$ = "; CHR$(34) + instring$ + CHR$(34);
  481.  
  482.    LOCATE 7, 16
  483.    PRINT msg1$;
  484.  
  485.    LOCATE 8, 3
  486.    PRINT "User format$ = "; CHR$(34) + format$ + CHR$(34);
  487.  
  488.    LOCATE 9, 16
  489.    PRINT msg2$;
  490.  
  491.    LOCATE 11, 3
  492.    PRINT "Test Qformateditnum : ";
  493.  
  494.    ExitCode% = 0  'returns 1 to 7  if flag set   see sub for details
  495.    UPflag = 0  'True OR False   set for exitkey
  496.    PUPflag = 0  'True OR False    ""
  497.    DNflag = 0  'True OR False    ""
  498.    PDNflag = 0  'True OR False    ""
  499.    RTflag = 1  'True OR False    ""   return key exit program
  500.    TABflag = 1  'True OR False    ""   tab key loops agian after pause
  501.    ESCflag = 0  'True or False    ""
  502. '
  503.    scol1 = POS(0) + 1: srow1 = 10: ecol1 = LEN(format$) + POS(0) + 2: erow1 = 12
  504.    Qsglbox scol1, srow1, ecol1, erow1
  505.     
  506. '
  507.    LOCATE 11, scol1 + 1
  508.  
  509.    instring$ = Qformateditnum(instring$, format$, ExitCode, UPflag, PUPflag, DNflag, PDNflag, RTflag, TABflag, ESCflag)
  510. '
  511.    LOCATE 13, 8
  512.    PRINT "Length of string: ";
  513.    PRINT LEN(instring$);
  514.  
  515.    LOCATE 14, 8
  516.    PRINT "String as returned: ";
  517.    PRINT instring$;
  518.  
  519.    LOCATE 16, 8
  520.    PRINT "Print using #########.##"; USING "#########.##"; VAL(instring$)
  521.  
  522.    LOCATE 17, 8
  523.    PRINT "ExitCode : ";
  524.    PRINT ExitCode%;
  525.  
  526.    SELECT CASE ExitCode%
  527.       CASE 1  'what to do if uparrow key exit
  528.               'could be
  529.               'GOTO previous entry
  530.  
  531.       CASE 2  'what to do if pageup key exit
  532.  
  533.       CASE 3  'what to do if downarrow key exit
  534.               'could be
  535.               'GOTO next entry
  536.  
  537.       CASE 4  'what to do if pagedown key exit
  538.  
  539.       CASE 5  'what to do if enter key exit
  540.               'could be accept entry
  541.          
  542.               msg$ = "Anykey to Continue "
  543.               Qmessage msg$, 22
  544. '  Wait until there's a character
  545. '
  546.          choice$ = ""
  547.          WHILE choice$ = ""
  548.             choice$ = INKEY$
  549.          WEND
  550.  
  551. 'to be changed to a loop.
  552.          
  553.          msg$ = "ESC restores CTRL-E Clears, all other edit keys function normal"
  554.          Qmessage msg$, 3
  555.          RETURN
  556.  
  557.       CASE 6  'what to do if tab key exit
  558.               'could be return to menu
  559.          GOTO ENDPROG
  560.    END SELECT
  561.  
  562.    CLS
  563.    END
  564.  
  565. 'DATE: 05/30/90
  566. '
  567. 'clear line from cursur to end of line without moving cursor
  568. '
  569. '
  570.    SUB Qclreol
  571.       retpos = POS(0)
  572.       clrlen = 79 - POS(0)
  573.       PRINT SPACE$(clrlen);
  574.       LOCATE , retpos
  575.    END SUB
  576.  
  577. SUB Qclrscrn (startline, endline, startcol, endcol)
  578.  
  579.      FOR c = startline TO endline
  580.      LOCATE c, startcol
  581.      PRINT STRING$(endcol - startcol, " ");
  582.      NEXT
  583.  
  584. END SUB
  585.  
  586. '
  587.   SUB Qdblbox (leftcol, leftrow, rightcol, rightrow)
  588. ' call routine
  589. '    leftcol = 1: leftrow = 1: rightcol = 80: rightrow = 23
  590. '    call Qdblbox(leftcol,leftrow,rightcol,rightrow)
  591. 'Qdblbox
  592.       LOCATE leftrow, leftcol
  593. 'draw top of box
  594.       PRINT CHR$(201);
  595.       FOR i = (leftcol + 1) TO (rightcol - 1)
  596.          PRINT CHR$(205);
  597.       NEXT i
  598.       PRINT CHR$(187)
  599. 'draw side of box
  600.       FOR i = (leftrow + 1) TO (rightrow - 1)
  601.          LOCATE i, leftcol
  602.          PRINT CHR$(186);
  603.          LOCATE i, rightcol
  604.          PRINT CHR$(186);
  605.       NEXT i
  606. 'draw bottom of box
  607.       LOCATE rightrow, leftcol
  608.       PRINT CHR$(200);
  609.       FOR i = (leftcol + 1) TO (rightcol - 1)
  610.          PRINT CHR$(205);
  611.       NEXT i
  612.       PRINT CHR$(188);
  613.    END SUB
  614.  
  615. '
  616. 'draws border around screen
  617. '
  618.    SUB Qdrawscreen
  619.  
  620.       LOCATE 2, 4
  621.       PRINT DATE$;
  622.  
  623.       LOCATE 2, 65
  624.       PRINT "Version 2.00";
  625.  
  626.       msg$ = "COPYRIGHT 1990     Formatted Input Routine      BY: RAYMOND E DIXON"
  627.       Qmessage msg$, 24
  628.  
  629.       Qdblbox 1, 1, 80, 25
  630.       Qsglbox 2, 21, 79, 23
  631.  
  632.    END SUB
  633.  
  634. 'DATE: 05/30/90
  635. '     sub required with Qformateditnum
  636. '
  637.    SUB QformatDEC (number$, beforeDEC, afterdec)
  638. '
  639. '  Sub Routine to handle the number of decimal characters in a string
  640. '
  641.       length = LEN(number$)
  642.       delimit = INSTR(number$, ".")
  643.       IF delimit = 0 THEN
  644.          beforeDEC = length
  645.          afterdec = 0
  646.       END IF
  647.       IF delimit <> 0 THEN
  648.          IF LEFT$(number$, 1) = "." THEN
  649.             beforeDEC = 0
  650.             afterdec = length - 1
  651.          END IF
  652.          IF RIGHT$(number$, 1) = "." THEN
  653.             afterdec = 0
  654.             beforeDEC = length - 1
  655.          END IF
  656.          IF delimit <> 1 OR delimit <> length THEN
  657.             beforeDEC = delimit - 1
  658.             afterdec = (length - beforeDEC) - 1
  659.          END IF
  660.       END IF
  661.       IF length = 0 THEN
  662.          beforeDEC = 0
  663.          afterdec = 0
  664.       END IF
  665.    END SUB
  666.  
  667. 'DATE: 05/30/90
  668. '           numeric formats allow higest
  669. '           value of format position.
  670. '
  671. '      format$ = "99999.99" decimal   ( any decimal position)
  672. '      format$ = "99" numbers only  < (99 max) each digit = to max value
  673. '      format$ = "19" (19) is max value
  674. '
  675. '      use basic print using "####.##";VAL(instring$) for decimal numbers
  676. '      or integer.            decimal  pos and length optional
  677. '
  678. '       USE LOCATE ROW,COLUMN
  679. '
  680. '       maybe passed by parameters if you like to add to parms
  681. '
  682. '       column = Column pos to start printing
  683. '       Row = Row to start printing
  684. '
  685. '       set editforeground color  before call
  686. '       set editbackgroung color  before call
  687. '
  688. '       ExitCode = VALUE EXIT  1 TO 7
  689. '
  690. '       set flags to enable  to exit on key
  691. '
  692. '       UPflag     = True  ,exitcode =  1
  693. '       PGUPflag   = True  ,exitcode =  2
  694. '       DNflag     = True  ,exitcode =  3
  695. '       PGDNflag   = True  ,exitcode =  4
  696. '       RETflag    = True  ,exitcode =  5
  697. '       TABflag    = True  ,exitcode =  6
  698. '       ESCflag    = True  ,exitcode =  7
  699. '
  700. '       ESC key restores field if True or False
  701. '
  702. '   sample how to handle exitcode after input routine (see program).
  703. '
  704. '   SELECT CASE ExitCode%
  705. '
  706. '       CASE 1 'what to do if uparrow key exit
  707. '               could be
  708. '               GOTO previous entry
  709. '
  710. '       CASE 2 'what to do if pageup key exit
  711. '
  712. '       CASE 3 'what to do if downarrow key exit
  713. '               could be
  714. '               GOTO next entry
  715. '       CASE 4 'what to do if pagedown key exit
  716. '
  717. '       CASE 5 'what to do if enter key exit
  718. '                could be accept entry
  719. '       CASE 6 'what to do if tab key exit
  720. '               'could be return to menu
  721. '
  722. '   END SELECT
  723. '
  724. '
  725.    FUNCTION Qformateditnum$ (work$, format$, ExitCode, UPflag, PGUPflag, DNflag, PGDNflag, RETflag, TABflag, ESCflag)
  726.  
  727.       SHARED editbackground, editforeground
  728.  
  729. '
  730. ' Define names similar to keyboard names with their equivalent key codes.
  731. '  const maybe moved to main code and used for all routines
  732. '
  733.       CONST SPACE = 32, ESC = 27, enter = 13, TABKEY = 9
  734.       CONST DOWN = 80, UP = 72, LEFT = 75, RIGHT = 77
  735.       CONST HOME = 71, ENDK = 79, PGDN = 81, PGUP = 73
  736.       CONST INS = 82, DEL = 83, NULL = 0, CTRLE = 5
  737.       CONST CTRLD = 4, CTRLG = 7, CTRLH = 8, CTRLS = 19, CTRLV = 22
  738.       CONST True = 1, False = 0
  739.       STATIC curpos  'retain cursor pos.
  740. '
  741. ' comment out next two lines and pass row and col as parameters
  742. ' if you would too.
  743. '
  744.       row = CSRLIN
  745.       col = POS(0)
  746.       firsttime = 1
  747.       length = LEN(format$)
  748. '
  749.       SELECT CASE LEN(work$)
  750.          CASE IS > length
  751. '
  752. 'Make work$ the right length
  753. '
  754.             work$ = RIGHT$(work$, length)
  755.          CASE IS < length
  756.             work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  757.       END SELECT
  758.       
  759.       IF INSTR(format$, ".") THEN
  760.          decflag = 1
  761.          IF INSTR(work$, ".") THEN
  762.             
  763.             QformatDEC (work$), bforeDEC, aftDEC
  764.             QformatDEC (format$), beforeDEC, afterdec
  765.             work$ = Qremovechar$((work$), ".")
  766.             IF afterdec > aftDEC THEN
  767.                work$ = work$ + STRING$(afterdec - (aftDEC - 1), "0")
  768.             END IF
  769.             IF afterdec < aftDEC THEN
  770.                work$ = STRING$(aftDEC - (afterdec - 1), " ") + LEFT$(work$, beforeDEC + (afterdec - 1))
  771.             END IF
  772.          ELSE
  773.             QformatDEC format$, beforeDEC, afterdec
  774.             work$ = work$ + STRING$(afterdec + 1, "0")
  775.          END IF
  776.       ELSE
  777.          QformatDEC (work$), beforeDEC, afterdec
  778.          work$ = LEFT$(work$, beforeDEC)
  779.          afterdec = 0
  780.          work$ = STRING$(length - LEN(work$), " ") + work$
  781.          decflag = 0
  782.       END IF
  783. '
  784. 'length of input = to format set by user
  785. 'length of format$ is edit length not user length
  786.  
  787.       
  788.       SELECT CASE LEN(work$)
  789.          CASE IS > length
  790. '
  791. 'Make work$ the right length after dec adjust
  792. '
  793.             work$ = RIGHT$(work$, length)
  794.          CASE IS < length
  795.             IF decflag THEN
  796.                work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  797.             ELSE
  798.                work$ = STRING$(length - LEN(work$), " ") + work$
  799.             END IF
  800.       END SELECT
  801. '
  802. 'print user data with formated string
  803. '
  804.       temp$ = work$
  805.       work$ = STRING$(length, " ")
  806. '
  807. 'step through format$ and insert org characters
  808. '
  809.       k = 1
  810.       FOR j = 1 TO length
  811.          Character$ = MID$(format$, j, 1)
  812.          IF INSTR(".", Character$) THEN
  813.             MID$(work$, j, 1) = Character$
  814.          ELSE
  815. '
  816. 'mix with format$
  817. '
  818.             char$ = MID$(temp$, k, 1)
  819.             MID$(work$, j, 1) = char$
  820.             k = k + 1
  821.          END IF
  822.       NEXT j
  823. '
  824. ' got formatted string so save for ESC and restore.
  825. '
  826.       org$ = work$
  827.       curpos = 1
  828.       ExitCode = 0
  829. '
  830. ' EDIT in reverse video
  831. '
  832.       COLOR editforeground, editbackground
  833.       LOCATE row, col
  834.       PRINT work$;  '
  835. '
  836. ' loop until an exit
  837. '
  838.       DO
  839.          
  840.          SELECT CASE curpos
  841. '
  842. '  Cursor position too long
  843. '
  844.             CASE IS > length
  845.                curpos = length
  846.             CASE IS < 1
  847.                curpos = 1
  848.          END SELECT
  849. '
  850.          LOCATE row, col
  851.          PRINT work$;
  852.  
  853. '
  854. 'set cursor to end of field
  855. '
  856.          LOCATE row, col + length - 1, 1, 7, 7
  857. '
  858. '  Wait until there's a character
  859. '
  860.          choice$ = ""
  861.          WHILE choice$ = ""
  862.             choice$ = INKEY$
  863.          WEND
  864.          LOCATE , , 0
  865. '
  866. '  Normal character
  867. '
  868.          IF LEN(choice$) = 1 THEN
  869.             special$ = MID$(format$, curpos, 1)
  870.             keychoice = ASC(choice$)
  871.             SELECT CASE keychoice
  872.                CASE enter
  873. '
  874. 'return exitcode is set if flag set
  875. '
  876.                   IF RETflag = True THEN
  877.                      ExitCode = 5
  878.                      EXIT DO
  879.                   END IF
  880.                CASE TABKEY  'TAB is set
  881.                   IF TABflag = True THEN
  882.                      ExitCode = 6
  883.                      EXIT DO
  884.                   END IF
  885.                CASE ESC  ' ESC restores edit string
  886.                   work$ = org$
  887.                   curpos = 1
  888.                   IF ESCflag = True THEN
  889.                      ExitCode = 7
  890.                      EXIT DO
  891.                   END IF
  892.                CASE CTRLE  'erase number
  893.  
  894.                   work$ = ""
  895.  
  896.                   IF LEN(work$) = 0 THEN
  897.                      IF afterdec > 0 THEN
  898.                         work$ = STRING$(afterdec, "0")
  899.                          IF LEN(work$) < length THEN
  900.                            IF decflag THEN
  901.                               work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  902.                            ELSE
  903.                               work$ = STRING$(length - LEN(work$), " ") + work$
  904.                            END IF
  905.                            work$ = Quserformat$(work$, format$)
  906.                         END IF
  907.                      ELSE
  908.                         work$ = ""
  909.                         IF LEN(work$) < length THEN
  910.                            IF decflag THEN
  911.                               work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  912.                            ELSE
  913.                               work$ = STRING$(length - LEN(work$), " ") + work$
  914.                            END IF
  915.                            work$ = Quserformat$(work$, format$)
  916.                         END IF
  917.                      END IF
  918.                   END IF
  919.             END SELECT
  920. '
  921.             SELECT CASE special$
  922.                CASE "0" TO "9"  'get numbers only
  923.  
  924.                   IF choice$ <= special$ THEN  'get pos max value
  925.                      keychoice = ASC(choice$)
  926.                   ELSE
  927.                      keychoice = 0
  928.                   END IF
  929.             END SELECT
  930. '
  931.             SELECT CASE choice$
  932.  
  933.                CASE "-"  'handle neg numbers
  934.                   temp$ = work$
  935.                   work$ = ""
  936.  
  937.                   IF LEN(work$) = 0 THEN
  938.                      IF afterdec > 0 THEN
  939.                         work$ = LTRIM$(RTRIM$(choice$)) + STRING$(afterdec, "0")
  940.                          IF LEN(work$) < length THEN
  941.                            IF decflag THEN
  942.                               work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  943.                            ELSE
  944.                               work$ = STRING$(length - LEN(work$), " ") + work$
  945.                            END IF
  946.                            work$ = Quserformat$(work$, format$)
  947.                         END IF
  948.                      ELSE
  949.                         work$ = LTRIM$(RTRIM$(choice$))
  950.                         IF LEN(work$) < length THEN
  951.                            IF decflag THEN
  952.                               work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  953.                            ELSE
  954.                               work$ = STRING$(length - LEN(work$), " ") + work$
  955.                            END IF
  956.                            work$ = Quserformat$(work$, format$)
  957.                         END IF
  958.                      END IF
  959.                   END IF
  960.             END SELECT
  961. '
  962.             SELECT CASE CHR$(keychoice)
  963.  
  964.                CASE "0" TO "9"  'numbers only
  965.  
  966.                   FOR j = 1 TO length
  967.                      Character$ = MID$(format$, j, 1)
  968.                      IF INSTR(".", Character$) THEN
  969.                         MID$(work$, j, 1) = CHR$(255)
  970.                         cursor = cursor + 1
  971.                      END IF
  972.                   NEXT j
  973.                      
  974.                      work$ = Qremovechar$(work$, CHR$(255))
  975.                      IF firsttime = 1 THEN
  976.                      work$ = STRING$(afterdec, "0") + LTRIM$(RTRIM$(choice$))
  977.  
  978.                      firsttime = 0
  979.                      ELSE
  980.                      work$ = LTRIM$(RTRIM$(work$)) + LTRIM$(RTRIM$(choice$))
  981.                      END IF
  982. '
  983.                   IF afterdec > 0 THEN
  984.                      IF LEN(work$) >= afterdec THEN
  985.                         IF LEFT$(work$, 1) = "0" THEN
  986.                            work$ = RIGHT$(work$, LEN(work$) - 1)
  987.                         END IF
  988.                      END IF
  989.                   END IF
  990.  
  991.                   IF afterdec > 0 THEN
  992.                   IF LEN(work$) >= afterdec + 1 THEN
  993.                      IF MID$(work$, 2, 1) = "0" THEN
  994.                         work$ = "-" + RIGHT$(work$, LEN(work$) - 2)
  995.                      END IF
  996.                   END IF
  997.                   END IF
  998. '
  999.                   IF LEN(work$) < length THEN
  1000.                      IF decflag THEN
  1001.                         work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  1002.                      ELSE
  1003.                         work$ = STRING$(length - LEN(work$), " ") + work$
  1004.                      END IF
  1005.                   END IF
  1006.                   work$ = Quserformat$(work$, format$)
  1007.                   curpos = curpos + 1
  1008.             END SELECT
  1009.          ELSE
  1010. '
  1011. 'Extended character
  1012. '
  1013.             keychoice = ASC(MID$(choice$, 2))
  1014.             SELECT CASE keychoice
  1015.                CASE DEL  '  Delete
  1016. 'remove format for delete
  1017.                   FOR j = 1 TO length
  1018.                      Character$ = MID$(format$, j, 1)
  1019.                      IF INSTR(".", Character$) THEN
  1020.                         MID$(work$, j, 1) = CHR$(255)
  1021.                      ELSE
  1022.                      END IF
  1023.                   NEXT j
  1024. '
  1025. 'remove dummy blanks
  1026. '
  1027.                   work$ = Qremovechar$(work$, CHR$(255))
  1028.                   work$ = LTRIM$(RTRIM$(work$))
  1029.                   IF afterdec > 0 THEN
  1030.                      IF LEN(work$) <= afterdec THEN
  1031.                         work$ = "0" + work$
  1032.                      END IF
  1033.                   END IF
  1034.                   IF LEN(work$) THEN
  1035.                      work$ = LEFT$(work$, LEN(work$) - 1)
  1036.                      IF decflag THEN
  1037.                         work$ = STRING$(length - LEN(work$) - 1, " ") + work$
  1038.                      ELSE
  1039.                         work$ = STRING$(length - LEN(work$), " ") + work$
  1040.                      END IF
  1041.                   END IF
  1042.                   work$ = Quserformat$((work$), format$)
  1043.                   curpos = curpos - 1
  1044.                CASE UP  '  Up arrow
  1045.                   IF UPflag = True THEN
  1046.                      ExitCode = 1
  1047.                      EXIT DO
  1048.                   END IF
  1049.                CASE PGUP  '  Page up
  1050.                   IF PGUPflag = True THEN
  1051.                      ExitCode = 2
  1052.                      EXIT DO
  1053.                   END IF
  1054.                CASE PGDN  '  Page down
  1055.                   IF PGDNflag = True THEN
  1056.                      ExitCode = 4
  1057.                      EXIT DO
  1058.                   END IF
  1059.                CASE DOWN  '  Down arrow
  1060.                   IF DNflag = True THEN
  1061.                      ExitCode = 3
  1062.                      EXIT DO
  1063.                   END IF
  1064.                CASE ELSE
  1065.             END SELECT
  1066.          END IF
  1067.       firsttime = 0
  1068.       LOOP WHILE ExitCode = 0
  1069. '
  1070. 'all done now clean up
  1071. '
  1072.       COLOR normal, BACKGROUND  'set color to normal
  1073.  
  1074.       LOCATE row, col, CURSOROFF
  1075.       PRINT work$;
  1076.  
  1077. '
  1078. ' REMOVE format$
  1079. '
  1080.       FOR j = 1 TO length
  1081.          Character$ = MID$(format$, j, 1)
  1082.          char$ = MID$(work$, j, 1)
  1083.          IF INSTR(".", Character$) THEN
  1084. 'skip
  1085.          ELSE
  1086. '
  1087. 'remove temp blanks
  1088. '
  1089.             IF char$ = CHR$(255) THEN
  1090. 'skip
  1091.             ELSE
  1092.                tmp$ = tmp$ + char$
  1093.             END IF
  1094.          END IF
  1095.       NEXT j
  1096.       COLOR normal, BACKGROUND  'set color to normal
  1097. '
  1098. 'remove any spaces
  1099. '
  1100.       tmp$ = RTRIM$(LTRIM$(tmp$))
  1101.       IF LEN(tmp$) - 1 < afterdec THEN
  1102.          IF LEFT$(tmp$, 1) = "-" THEN
  1103.             tmp$ = "-" + STRING$(afterdec - LEN(tmp$) + 1, "0") + RIGHT$(tmp$, LEN(tmp$) - 1)
  1104.          END IF
  1105.       END IF
  1106.       IF LEN(tmp$) < 2 THEN
  1107.          tmp$ = "0" + tmp$
  1108.       END IF
  1109. '
  1110. 'reinsert decimal in correct position
  1111. '
  1112.       IF decflag THEN
  1113.          rwork$ = RIGHT$(tmp$, afterdec)
  1114.          lwork$ = LEFT$(tmp$, LEN(tmp$) - LEN(rwork$))
  1115.          work$ = lwork$ + "." + rwork$
  1116.       END IF
  1117. '
  1118.  
  1119.       Qformateditnum$ = LTRIM$(RTRIM$(work$))
  1120. '
  1121.    END FUNCTION
  1122.  
  1123. 'DATE: 05/30/90
  1124. '                     Raymond E Dixon
  1125. '                     5815 Buckley dr
  1126. '                     Jacksonville, Fl 32244
  1127. '                     (904) 778-4048
  1128. '
  1129. '  IF ANYONE MAKES ANY INPROVEMENTS I WOULD LIKE YOU TO RENAME THIS SUB
  1130. '  TO A NEW NAME. AND IF YOU WOULD SEND ME A COPY.
  1131. '
  1132. '       formated input routine with user format
  1133. '
  1134. '       assign values before calling routine
  1135. '
  1136. '       work$ =""  or string to edit
  1137. '
  1138. '           numeric formats allow higest
  1139. '           value of format position.
  1140. '
  1141. '      format$ = "99" numbers only  < (99 max) each digit = to max value
  1142. '      format$ = "19" (19) is max value
  1143. '      format$ = "999-99-9999" SS number
  1144. '      format$ = "999-9999"       7  digit phone
  1145. '      format$ = "(999) 999-9999" 10 digit phone
  1146. '      format$ = "19/39/99"  date format
  1147. '      format$ = "########" alphanumeric set for 8 characters (maybe more or less)
  1148. '      format$ = "@@@@@@@@" alpha only   same as above
  1149. '      format$ = "Y/N:*"    force YN answer.
  1150. '      format$ = "M/F:|"    force MF answer.
  1151. '      format$ = "~"       'force enter key for prompts or other exit key.
  1152. '      format$ = may be any format you can create in a basic string
  1153. '                even you can include the Prompt if you like.
  1154. '
  1155. '      format$ = "Test Data: 99" 'this format will print
  1156. '                 Test Data: your value passed
  1157. '                            in the the length of 2
  1158. '                            Seting numbers 1 to 99.
  1159. '
  1160. '       USE LOCATE ROW,COLUMN
  1161. '
  1162. '       maybe passed by parameters if you like to add to parms
  1163. '
  1164. '       column = Column pos to start printing
  1165. '       Row = Row to start printing
  1166. '
  1167. '       set foreground color  before call
  1168. '
  1169. '       set backgroung color  before call
  1170. '
  1171. '       ExitCode = VALUE EXIT  1 TO 7
  1172. '
  1173. '       set flags to enable  to exit on key
  1174. '
  1175. '       UPflag     = True  ,exitcode =  1
  1176. '       PGUPflag   = True  ,exitcode =  2
  1177. '       DNflag     = True  ,exitcode =  3
  1178. '       PGDNflag   = True  ,exitcode =  4
  1179. '       RETflag    = True  ,exitcode =  5
  1180. '       TABflag    = True  ,exitcode =  6
  1181. '       ESCflag    = True  ,exitcode =  7
  1182. '
  1183. '       ESC key restores field if True or False
  1184. '
  1185. '        force case if set.
  1186. '                        caseflag = 0 any case
  1187. '                                 = 1 for upper
  1188. '                                 = 2 for lower
  1189. '
  1190. '   sample how to handle exitcode after input routine (see program).
  1191. '
  1192. '   SELECT CASE ExitCode%
  1193. '
  1194. '       CASE 1 'what to do if uparrow key exit
  1195. '               could be
  1196. '               GOTO previous entry
  1197. '
  1198. '       CASE 2 'what to do if pageup key exit
  1199. '
  1200. '       CASE 3 'what to do if downarrow key exit
  1201. '               could be
  1202. '               GOTO next entry
  1203. '       CASE 4 'what to do if pagedown key exit
  1204. '
  1205. '       CASE 5 'what to do if enter key exit
  1206. '                could be accept entry
  1207. '       CASE 6 'what to do if tab key exit
  1208. '               'could be return to menu
  1209. '
  1210. '   END SELECT
  1211. '
  1212. '
  1213.    FUNCTION Qformateditstr$ (work$, format$, caseflag, ExitCode, UPflag, PGUPflag, DNflag, PGDNflag, RETflag, TABflag, ESCflag)
  1214. '
  1215. ' Define names similar to keyboard names with their equivalent key codes.
  1216. '  const maybe moved to main code and used for all routines
  1217. '
  1218.       CONST SPACE = 32, ESC = 27, enter = 13, TABKEY = 9
  1219.       CONST DOWN = 80, UP = 72, LEFT = 75, RIGHT = 77
  1220.       CONST HOME = 71, ENDK = 79, PGDN = 81, PGUP = 73
  1221.       CONST INS = 82, DEL = 83, NULL = 0, CTRLE = 5
  1222.       CONST CTRLD = 4, CTRLG = 7, CTRLH = 8, CTRLS = 19, CTRLV = 22
  1223.       CONST True = 1, False = NOT True
  1224.       STATIC insertmode, curpos  'retain insert mode and cursor pos.
  1225. '
  1226. ' comment out next two lines and pass row and col as parameters
  1227. ' if you would too.
  1228. '
  1229.       SHARED editbackground, editforeground
  1230.  
  1231.       row = CSRLIN
  1232.       col = POS(0)
  1233.       firsttime = 1
  1234. '
  1235. 'step through format$
  1236. '
  1237.       length = LEN(format$)
  1238.       FOR j = 1 TO length
  1239.          FChr$ = MID$(format$, j, 1)
  1240.          SELECT CASE FChr$
  1241. '
  1242. 'skip special characters
  1243. '
  1244.             CASE "~", "@", "0" TO "9", "#", "*", "|"
  1245.             CASE ELSE
  1246. '
  1247. 'values to skip over in format
  1248. '
  1249.                formatVALUES$ = formatVALUES$ + FChr$
  1250.          END SELECT
  1251.       NEXT j
  1252. '
  1253. 'length of input = to format set by user
  1254. 'length of format$ is edit length not user length
  1255. '
  1256.  
  1257. '
  1258. '  Insert Mode flag
  1259. '
  1260.       insertmode = 0
  1261.  
  1262.       SELECT CASE LEN(work$)
  1263.          CASE IS > length
  1264. '
  1265. 'String too long
  1266. 'Make work$ the right length
  1267. '
  1268.             work$ = MID$(work$, 1, length)
  1269.          CASE IS < length
  1270.             work$ = work$ + STRING$(length - LEN(work$), SPACE)
  1271.       END SELECT
  1272. '
  1273. 'print user data with formated string
  1274.  
  1275.       temp$ = work$
  1276.       work$ = STRING$(length, " ")
  1277.       
  1278. '
  1279. 'set to start of org string
  1280. '
  1281.       k = 1
  1282. '
  1283. 'step through format$ and insert org characters
  1284. '
  1285.       FOR j = 1 TO length
  1286.          Character$ = MID$(format$, j, 1)
  1287.          IF INSTR(formatVALUES$, Character$) THEN
  1288.             MID$(work$, j, 1) = Character$
  1289.          ELSE
  1290. '
  1291. 'mix with format$
  1292. '
  1293.             char$ = MID$(temp$, k, 1)
  1294.             MID$(work$, j, 1) = char$
  1295.             k = k + 1
  1296.          END IF
  1297.       NEXT j
  1298. '
  1299. ' got formatted string so save for ESC and restore.
  1300. '
  1301.       org$ = work$
  1302.       curpos = 1
  1303.       ExitCode = 0
  1304. '
  1305. ' EDIT in reverse video
  1306.  
  1307.       COLOR editforeground, editbackground
  1308.       LOCATE row, col
  1309.       PRINT work$;
  1310.  
  1311. '
  1312. ' loop until an exit
  1313. '
  1314.       DO
  1315.          DO
  1316.             IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1317.                curpos = curpos + 1
  1318.             ELSE
  1319.                EXIT DO
  1320.             END IF
  1321.             IF curpos > length THEN
  1322.                curpos = length
  1323.                DO
  1324.                   IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1325.                      curpos = curpos - 1
  1326.                   ELSE
  1327.                      EXIT DO
  1328.                   END IF
  1329.                LOOP
  1330.             END IF
  1331.          LOOP
  1332.          SELECT CASE curpos
  1333. '
  1334. '  Cursor position too long
  1335. '
  1336.             CASE IS > length
  1337.                curpos = length
  1338.             CASE IS < 1
  1339.                curpos = 1
  1340.          END SELECT
  1341.  
  1342.        LOCATE row, col
  1343.  
  1344.          PRINT work$;
  1345. '
  1346. ' change curor for insert mode
  1347. 'InsertMode is on
  1348. '
  1349.          IF insertmode = True THEN
  1350.             LOCATE row, col + curpos - 1, 1, 0, 15
  1351.          ELSE
  1352.             LOCATE row, col + curpos - 1, 1, 7, 7
  1353.          END IF
  1354.  
  1355.       IF INSTR(format$, "~") THEN
  1356.       LOCATE row, col + curpos - 1, 0, 7, 7
  1357.       END IF
  1358. '
  1359. '  Wait until there's a character
  1360. '
  1361.          choice$ = ""
  1362.          WHILE choice$ = ""
  1363.             choice$ = INKEY$
  1364.          WEND
  1365.          LOCATE , , 0
  1366. '
  1367. '  Normal character
  1368. '
  1369.          IF LEN(choice$) = 1 THEN
  1370.             special$ = MID$(format$, curpos, 1)
  1371.             keychoice = ASC(choice$)
  1372.             SELECT CASE keychoice
  1373.                CASE enter
  1374. '
  1375. 'return is set
  1376. '
  1377.                   IF RETflag = True THEN
  1378.                      ExitCode = 5
  1379.                      EXIT DO
  1380.                   END IF
  1381.                CASE TABKEY  'TAB is set
  1382.                   IF TABflag = True THEN
  1383.                      ExitCode = 6
  1384.                      EXIT DO
  1385.                   END IF
  1386.                CASE CTRLE  ' CTRL E erases edit string
  1387.                   work$ = STRING$(length, " ")
  1388.                   temp$ = STRING$(length, " ")
  1389. '
  1390. 'set to start of org string
  1391. '
  1392.       k = 1
  1393. '
  1394. 'step through format$ and insert org characters
  1395. '
  1396.       FOR j = 1 TO length
  1397.          Character$ = MID$(format$, j, 1)
  1398.          IF INSTR(formatVALUES$, Character$) THEN
  1399.             MID$(work$, j, 1) = Character$
  1400.          ELSE
  1401. '
  1402. 'mix with format$
  1403. '
  1404.             char$ = MID$(temp$, k, 1)
  1405.             MID$(work$, j, 1) = char$
  1406.             k = k + 1
  1407.          END IF
  1408.       NEXT j
  1409.  
  1410.                   curpos = 1
  1411.  
  1412.                CASE ESC  ' ESC restores edit string
  1413.                   work$ = org$
  1414.                   curpos = 1
  1415.                   IF ESCflag = True THEN
  1416.                      ExitCode = 7
  1417.                      EXIT DO
  1418.                   END IF
  1419.             END SELECT
  1420.             SELECT CASE special$
  1421.                CASE "0" TO "9"  'get numbers only
  1422.                   IF choice$ <= special$ THEN
  1423.                      keychoice = ASC(choice$)
  1424.                   ELSE
  1425.                      keychoice = 0
  1426.                   END IF
  1427.                CASE "@"  ' force alpha only
  1428.                   IF UCASE$(choice$) >= "A" AND UCASE$(choice$) <= "Z" OR choice$ = " " OR choice$ = CHR$(8) THEN
  1429.                      keychoice = ASC(choice$)
  1430.                   ELSE
  1431.                      keychoice = 0
  1432.                   END IF
  1433.                CASE "*"  ' force YN only
  1434.                   IF UCASE$(choice$) = "Y" OR UCASE$(choice$) = "N" OR choice$ = " " THEN
  1435.                      keychoice = ASC(choice$)
  1436.                   ELSE
  1437.                      keychoice = 0
  1438.                   END IF
  1439.                CASE "|"  ' force MF only
  1440.                   IF UCASE$(choice$) = "M" OR UCASE$(choice$) = "F" OR choice$ = " " THEN
  1441.                      keychoice = ASC(choice$)
  1442.                   ELSE
  1443.                      keychoice = 0
  1444.                   END IF
  1445.  
  1446.                CASE "~"  'force enter only
  1447.                   IF UCASE$(choice$) = "" THEN
  1448.                      keychoice = ASC(choice$)
  1449.                   ELSE
  1450.                      keychoice = 0
  1451.                   END IF
  1452.             END SELECT
  1453.  
  1454.             SELECT CASE keychoice
  1455.                CASE SPACE TO 126  '  Normal ascii char
  1456.                   SELECT CASE caseflag
  1457.                      CASE 1  '  Make it upper
  1458.                         choice$ = UCASE$(choice$)
  1459.                         keychoice = ASC(choice$)
  1460.                      CASE 2  '  Make it lower
  1461.                         choice$ = LCASE$(choice$)
  1462.                         keychoice = ASC(choice$)
  1463.                   END SELECT
  1464.                   IF insertmode = 0 THEN
  1465.  
  1466.                      MID$(work$, curpos, 1) = CHR$(keychoice)
  1467.                      curpos = curpos + 1
  1468.  
  1469.                      IF firsttime = 1 THEN
  1470.  
  1471.                      work$ = choice$ + STRING$(length - 1, " ")
  1472.                      work$ = Quserformat$((work$), format$)
  1473.  
  1474.                      firsttime = 0
  1475.  
  1476.                      END IF
  1477.                   END IF
  1478.  
  1479.                   IF insertmode = 1 THEN
  1480. '
  1481. ' REMOVE format$
  1482. '
  1483.                      FOR j = 1 TO length
  1484.                         Character$ = MID$(format$, j, 1)
  1485.                         IF INSTR(formatVALUES$, Character$) THEN
  1486.                            MID$(work$, j, 1) = CHR$(255)
  1487.                            cursor = cursor + 1
  1488.                         END IF
  1489.                      NEXT j
  1490.                      IF curpos < length THEN
  1491.                         lwork$ = LTRIM$(LEFT$(work$, curpos - 1))
  1492.                         rwork$ = RTRIM$(RIGHT$(work$, length - (curpos - 1)))
  1493.                         work$ = LEFT$(lwork$ + choice$ + rwork$, length)
  1494.                         curpos = curpos + 1
  1495.                      ELSE
  1496.                         BEEP
  1497.                      END IF
  1498.                      
  1499.                      work$ = Qremovechar$((work$), CHR$(255))
  1500.                      work$ = Quserformat$((work$), format$)
  1501.  
  1502.                   END IF
  1503.                CASE 8, 127  '  Back space
  1504.                   IF curpos% > 1 THEN
  1505.                      IF INSTR(formatVALUES$, MID$(format$, curpos%, 1)) = 0 THEN
  1506.                         MID$(work$, curpos%, 1) = " "
  1507.                         curpos% = curpos% - 1
  1508.                      END IF
  1509.                      DO
  1510.                         IF curpos% > 0 THEN
  1511.                            IF INSTR(formatVALUES$, MID$(format$, curpos%, 1)) THEN
  1512.                               curpos% = curpos% - 1
  1513.                            ELSE
  1514.                               EXIT DO
  1515.                            END IF
  1516.                         ELSE
  1517.                            EXIT DO
  1518.                         END IF
  1519.                      LOOP
  1520.                      IF curpos% = 0 THEN
  1521.                         DO
  1522.                            curpos% = curpos% + 1
  1523.                            IF INSTR(formatVALUES$, MID$(format$, curpos%, 1)) = 0 THEN
  1524.                               EXIT DO
  1525.                            ELSE
  1526.                               EXIT DO
  1527.                            END IF
  1528.                         LOOP
  1529.                      END IF
  1530.                   END IF
  1531.                CASE ELSE
  1532.             END SELECT
  1533.          ELSE
  1534. '
  1535. 'Extended character
  1536. '           firsttime = 0
  1537.  
  1538.             keychoice = ASC(MID$(choice$, 2))
  1539.             SELECT CASE keychoice
  1540.                CASE LEFT  '  Left arrow
  1541.                   IF curpos > 1 THEN
  1542.                      curpos = curpos - 1
  1543.                      DO
  1544.                         IF curpos > 0 THEN
  1545.                            IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) THEN
  1546.                               curpos = curpos - 1
  1547.                            ELSE
  1548.                               EXIT DO
  1549.                            END IF
  1550.                         ELSE
  1551.                            EXIT DO
  1552.                         END IF
  1553.                      LOOP
  1554.                      IF curpos = 0 THEN
  1555.                         DO
  1556.                            curpos = curpos + 1
  1557.                            IF INSTR(formatVALUES$, MID$(format$, curpos, 1)) = 0 THEN
  1558.                               EXIT DO
  1559.                            END IF
  1560.                         LOOP
  1561.                      END IF
  1562.                   END IF
  1563.                CASE RIGHT  'Right arrow
  1564.                   curpos = curpos + 1
  1565.                CASE HOME  'Home key
  1566.                   curpos = 1
  1567.                CASE ENDK  '  End  key
  1568.                   curpos = length
  1569.                CASE INS  '  InsertMode
  1570. '
  1571. 'toggle insert mode
  1572. '
  1573.                   insertmode = 1 - insertmode
  1574.                CASE DEL  '  Delete
  1575.                   MID$(work$, curpos, 1) = CHR$(255)
  1576. '
  1577. ' REMOVE format$
  1578. '
  1579.                   FOR j = 1 TO length
  1580.                      Character$ = MID$(format$, j, 1)
  1581.                      IF INSTR(formatVALUES$, Character$) THEN
  1582.                         MID$(work$, j, 1) = CHR$(255)
  1583.                      END IF
  1584.                   NEXT j
  1585.                   IF curpos < length THEN
  1586.                      FOR j = curpos TO leng
  1587.                         IF j < length - 1 THEN
  1588.                            char$ = MID$(work$, j + 1, 1)
  1589.                            MID$(work$, j, 1) = char$
  1590.                            MID$(work$, length, 1) = CHR$(255)
  1591.                         END IF
  1592.                      NEXT j
  1593.                   END IF
  1594.                   work$ = Qremovechar$((work$), CHR$(255))
  1595.                   work$ = Quserformat$((work$), format$)
  1596.                CASE UP  '  Up arrow
  1597.                   IF UPflag = True THEN
  1598.                      ExitCode = 1
  1599.                      EXIT DO
  1600.                   END IF
  1601.                CASE PGUP  '  Page up
  1602.                   IF PGUPflag = True THEN
  1603.                      ExitCode = 2
  1604.                      EXIT DO
  1605.                   END IF
  1606.                CASE PGDN  '  Page down
  1607.                   IF PGDNflag = True THEN
  1608.                      ExitCode = 4
  1609.                      EXIT DO
  1610.                   END IF
  1611.                CASE DOWN  '  Down arrow
  1612.                   IF DNflag = True THEN
  1613.                      ExitCode = 3
  1614.                      EXIT DO
  1615.                   END IF
  1616.                CASE ELSE
  1617.             END SELECT
  1618.          END IF
  1619.       firsttime = 0
  1620.       LOOP WHILE ExitCode = 0
  1621. '
  1622. 'all done now clean up
  1623. '
  1624.       COLOR normal, BACKGROUND  'set color to normal
  1625.       LOCATE row, col, CURSOROFF
  1626.       PRINT work$;
  1627.  
  1628. '
  1629. ' REMOVE format$
  1630. '
  1631.       FOR j = 1 TO length
  1632.          Character$ = MID$(format$, j, 1)
  1633.          char$ = MID$(work$, j, 1)
  1634.          IF INSTR(formatVALUES$, Character$) THEN
  1635. 'skip
  1636.          ELSE
  1637. '
  1638. 'remove temp blanks
  1639. '
  1640.             IF char$ = CHR$(255) THEN
  1641. 'skip
  1642.             ELSE
  1643.                tmp$ = tmp$ + char$
  1644.             END IF
  1645.          END IF
  1646.       NEXT j
  1647.  
  1648. '
  1649. 'remove any spaces
  1650. '
  1651.       Qformateditstr$ = RTRIM$(LTRIM$(tmp$))
  1652. '
  1653.    END FUNCTION
  1654.  
  1655. 'prints msg at row
  1656. '
  1657.    SUB Qmessage (msg$, row)
  1658.       LOCATE row, 3
  1659.       PRINT SPACE$(76)
  1660.       ml = 80 - LEN(msg$)
  1661.       mp = ml \ 2
  1662.       LOCATE row, mp
  1663.       PRINT msg$;
  1664.    END SUB
  1665.  
  1666. 'DATE: 05/30/90
  1667. '
  1668.    FUNCTION Qremovechar$ (userstring$, skip$)
  1669. '
  1670.       length = LEN(userstring$)  'Get length of string.
  1671.       Character$ = ""
  1672.       FOR k = 1 TO length
  1673. '
  1674. 'Get individual Character from string, from left to right.
  1675. '
  1676.          char$ = MID$(userstring$, k, 1)
  1677. '
  1678. 'Test for valid chararacter.
  1679. '
  1680.          IF char$ = skip$ THEN
  1681. '
  1682. 'skip unwanted character
  1683. '
  1684.          ELSE
  1685. '
  1686. 'add character to string
  1687. '
  1688.             Character$ = Character$ + char$
  1689.          END IF
  1690.       NEXT
  1691. '
  1692.       Qremovechar$ = Character$
  1693. '
  1694.    END FUNCTION
  1695.  
  1696. 'DATE: 05/30/90
  1697. '  remove user format from string
  1698. '  see Quserformat$ for def of format
  1699. '
  1700.    FUNCTION Qremoveformat$ (work$, format$) STATIC
  1701.       IF LEN(work$) < LEN(format$) THEN
  1702.          EXIT FUNCTION
  1703.       END IF
  1704.       length = LEN(format$)
  1705. ' REMOVE format$
  1706.       FOR j = 1 TO length
  1707.          Character$ = MID$(format$, j, 1)
  1708.          char$ = MID$(work$, j, 1)
  1709.          IF INSTR(formatVALUES$, Character$) THEN
  1710. 'skip
  1711.          ELSE
  1712.             IF char$ = CHR$(255) THEN
  1713. 'skip
  1714.             ELSE
  1715.                tmp$ = tmp$ + char$
  1716.             END IF
  1717.          END IF
  1718.       NEXT j
  1719.       Qremoveformat$ = RTRIM$(LTRIM$(tmp$))
  1720.    END FUNCTION
  1721.  
  1722. '
  1723. SUB Qsglbox (scol1, srow1, ecol1, erow1)
  1724. '    scol1 = 1: srow1 = 1: ecol1 = 80: erow1 = 23
  1725.       LOCATE srow1, scol1
  1726. 'top
  1727.       PRINT CHR$(218);
  1728.       FOR i = (scol1 + 1) TO (ecol1 - 1)
  1729.          PRINT CHR$(196);
  1730.       NEXT i
  1731.       PRINT CHR$(191)
  1732. 'sides
  1733.       FOR i = (srow1 + 1) TO (erow1 - 1)
  1734.          LOCATE i, scol1
  1735.          PRINT CHR$(179);
  1736.          LOCATE i, ecol1
  1737.          PRINT CHR$(179);
  1738.       NEXT i
  1739. 'bottom
  1740.       LOCATE erow1, scol1
  1741.       PRINT CHR$(192);
  1742.       FOR i = (scol1 + 1) TO (ecol1 - 1)
  1743.          PRINT CHR$(196);
  1744.       NEXT i
  1745.       PRINT CHR$(217)
  1746.    END SUB
  1747.  
  1748. 'DATE: 05/30/90
  1749. '    will print string using format$
  1750. '    or convert to formated string
  1751. '      not for decimal numbers
  1752. '
  1753. '      format$ = "99" numbers only  < (99 max) each digit = to max value
  1754. '      format$ = "19" (19) is max value
  1755. '      format$ = "999-99-9999" SS number
  1756. '      format$ = "999-9999"       7  digit phone
  1757. '      format$ = "(999) 999-9999" 10 digit phone
  1758. '      format$ = "19/39/99"  date format
  1759. '      format$ = "########" alphanumeric set for 8 characters (maybe more or less)
  1760. '      format$ = "@@@@@@@@" alpha only   same as above
  1761. '      format$ = "Y/N:*"    force YN answer.
  1762. '      format$ = "~"        force enter key for prompts or other exit key.
  1763. '      format$ = may be any format you can create in a basic string
  1764. '                even you can include the Prompt if you like.
  1765. '
  1766. '      format$ = "Test Data: 99" 'this format will print
  1767. '                 Test Data: your value passed
  1768. '                            in the the length of 2
  1769. '                            Seting numbers 1 to 99.
  1770. '
  1771. '    locate row,col
  1772. '    print Quserformat$(string$,Format$);
  1773. '                  or
  1774. '    print Quserformat$("7784048","999-9999");
  1775. '                  or
  1776. '    a$ = Quserformat$(string$,Format$)
  1777. '    print a$;
  1778. '
  1779. '    output would be:  778-4048
  1780. '
  1781. ' remember if you pass string as parameter userformat modifies the string.
  1782. ' if you  pass as value it won't change.
  1783. '     (string$) passed as value.
  1784. '      string$  passed as address.
  1785. '
  1786. ' !! Quserformat alters string if passed as address !!
  1787. '    you can use removeformat to change it back.
  1788. '    instring$ = qremoveformat$(instring$,format$)
  1789. '
  1790. '
  1791.    FUNCTION Quserformat$ (work$, format$)
  1792. '
  1793. 'step through format$
  1794. '
  1795.       length = LEN(format$)
  1796.       FOR j = 1 TO length
  1797.          FChr$ = MID$(format$, j, 1)
  1798.          SELECT CASE FChr$
  1799. '
  1800. 'skip special characters
  1801. '
  1802.             CASE "~", "@", "0" TO "9", "#", "*", "|"
  1803.             CASE ELSE
  1804. '
  1805. 'values to skip over in format
  1806. '
  1807.                formatVALUES$ = formatVALUES$ + FChr$
  1808.          END SELECT
  1809.       NEXT j
  1810. '
  1811. 'print user data with formated string
  1812. '
  1813.       temp$ = work$
  1814.       work$ = STRING$(length, " ")
  1815. '
  1816. 'set to start of org string
  1817. '
  1818.       k = 1
  1819. '
  1820. 'step through format$ and insert org characters
  1821. '
  1822.       FOR j = 1 TO length
  1823.          Character$ = MID$(format$, j, 1)
  1824.          IF INSTR(formatVALUES$, Character$) THEN
  1825.             MID$(work$, j, 1) = Character$
  1826.          ELSE
  1827. '
  1828. 'mix with format$
  1829. '
  1830.             char$ = MID$(temp$, k, 1)
  1831.             MID$(work$, j, 1) = char$
  1832.             k = k + 1
  1833.          END IF
  1834.       NEXT j
  1835. '
  1836.       Quserformat$ = work$
  1837. '
  1838.    END FUNCTION
  1839.  
  1840.