home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / database / mulitfld / multifld.bas < prev    next >
Encoding:
BASIC Source File  |  1992-01-02  |  22.9 KB  |  826 lines

  1. 'I think many QB programmers will find this routine usefull. I wrote it
  2. 'because I HAD to have it. QUICKLY. Having recieved so much good stuff from
  3. 'QuickShare, I figure this small donation is the least I can do for now.
  4. 'I have since this was written, refined this and other high level routines
  5. 'which I will eventually make available at the usual cost - FREE.
  6. 'Use this code 'till your sick of it. It has served its purpose for me.
  7. 'Laugh at it 'till your gut hurts.
  8. 'When I wrote this, I threw it together from pieces parts of other
  9. 'things I had handy. It certainly is not optimized but it works fairly well.
  10. 'Jerry C. Jackson - Deland, Fl.
  11.   
  12.    DEFINT A-Z
  13.   
  14. ' Define color constants
  15.   
  16.    CONST black = 0
  17.    CONST blue = 1
  18.    CONST green = 2
  19.    CONST cyan = 3
  20.    CONST red = 4
  21.    CONST magenta = 5
  22.    CONST brown = 6
  23.    CONST white = 7
  24.    CONST bright = 8
  25.    CONST blink% = 16
  26.    CONST yellow = brown + bright
  27.   
  28. 'define constants used by the KeyCode% function CVI(a$ + STRING$(2, 0))
  29.    CONST FALSE = 0
  30.    CONST TRUE = NOT FALSE
  31.    CONST BACKSPACE = 8
  32.    CONST CTRLLEFTARROW = 29440
  33.    CONST CTRLRIGHTARROW = 29696
  34.    CONST CTRLY = 25
  35.    CONST CTRLQ = 17
  36.    CONST DEL = 21248
  37.    CONST ENDKEY = 20224
  38.    CONST ENTER = 13
  39.    CONST ESCAPE = 27
  40.    CONST HOME = 18176
  41.    CONST INSERTKEY = 20992
  42.    CONST UPARROW = 18432
  43.    CONST DOWNARROW = 20480
  44.    CONST LEFTARROW = 19200
  45.    CONST RIGHTARROW = 19712
  46.    CONST TABKEY = 9
  47.    CONST SHIFTTABKEY = 3840
  48.    CONST PGUP = 18688
  49.    CONST PGDN = 20736
  50.    CONST F10 = 17408
  51.    CONST CTRLHOME = 30464
  52.    CONST CTRLEND = 29952
  53.  
  54. 'define some more constants
  55.  
  56.    CONST illegal$ = "t255o0g64o2c64o0g64o2c64o0g64o2c64"
  57.    CONST fullfield$ = "t255o4g64o2c64o0g64o2c64o0g64o2c64"
  58.    CONST click$ = "t255o6c64"
  59.    CONST upperalpha$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  60.    CONST loweralpha$ = "abcdefghijklmnopqrstuvwxyz"
  61.    CONST decimal$ = "."
  62.    CONST number$ = "0123456789"
  63.    CONST otherkeys$ = "!@#$%^&*()-_=+[]{};':,./<>?\|`~"
  64.    CONST c32$ = " "
  65.   
  66.   
  67.    TYPE RegType
  68.       ax    AS INTEGER
  69.       bx    AS INTEGER
  70.       cx    AS INTEGER
  71.       dx    AS INTEGER
  72.       bp    AS INTEGER
  73.       si    AS INTEGER
  74.       di    AS INTEGER
  75.       flags AS INTEGER
  76.    END TYPE
  77.   
  78.   
  79. 'make arrays dynamic
  80. ' $DYNAMIC
  81.   
  82.    TYPE MultiFieldType
  83.      
  84.       edgeLine       AS INTEGER
  85.       ulrow          AS INTEGER
  86.       ulcol          AS INTEGER
  87.       lrrow          AS INTEGER
  88.       lrcol          AS INTEGER
  89.       fgedge         AS INTEGER
  90.       bgedge         AS INTEGER
  91.       fgbody         AS INTEGER
  92.       bgbody         AS INTEGER
  93.       fgNameActive       AS INTEGER
  94.       bgNameActive       AS INTEGER
  95.       fgNameInactive     AS INTEGER
  96.       bgNameInactive     AS INTEGER
  97.       fgValueActive  AS INTEGER
  98.       bgValueActive  AS INTEGER
  99.       fgValueInactive   AS INTEGER
  100.       bgValueInactive   AS INTEGER
  101.       fgtitle        AS INTEGER
  102.       bgtitle        AS INTEGER
  103.       fgPrompt       AS INTEGER
  104.       bgPrompt       AS INTEGER
  105.       fghelp         AS INTEGER
  106.       bghelp         AS INTEGER
  107.       rowhelp        AS INTEGER
  108.      
  109.    END TYPE
  110.   
  111.   
  112.    DECLARE FUNCTION KeyCode% ()
  113.    DECLARE FUNCTION EdKeyCode% ()
  114.   
  115.    DECLARE SUB EndProg ()
  116.    DECLARE SUB VideoState (mode%, columns%, page%)
  117.    DECLARE SUB EditCustomerInfo ()
  118.    DECLARE SUB MFI (mf AS MultiFieldType, mfFieldName$(), mfFieldCap%(), mfFieldValue$(), mfFieldMask$(), mfFieldLen%(), mfFieldPos(), mfFieldHelp$(), mfTitle$, mfPrompt$, mfScrollFileSpec$())
  119.    DECLARE SUB INTERRUPT (intnum%, inreg AS RegType, outreg AS RegType)
  120.    DECLARE SUB GetLinesInFile (filespec$, size%)
  121.    DECLARE SUB Hold ()
  122.    DECLARE SUB EndProgram ()
  123.    DECLARE SUB SetCursor (row%, col%, fc%, bc%)
  124.    DECLARE SUB MFIedit (a$, strlen%, mask$, extramask$, exitcode%, fg%, bg%)
  125.   
  126.   
  127.   
  128.    DIM SHARED allkeys$
  129.    allkeys$ = upperalpha$ + loweralpha$ + number$ + decimal$ + otherkeys$
  130.   
  131. 'get # of lines in file
  132.   
  133.    filespec$ = "0001.dat"
  134.    GetLinesInFile filespec$, n%
  135.    n% = n% - 15 'don't dimension anything for the file comment.
  136.   
  137. 'now that we know how big to dim the arrays, do it.
  138.    DIM SHARED mf1 AS MultiFieldType, mf1FieldName$(1 TO n%), mf1FieldCap%(1 TO n%), mf1FieldValue$(1 TO n%), mf1FieldMask$(1 TO n%, 1 TO 2), mf1FieldLen%(1 TO n%), mf1FieldPos%(1 TO n%, 1 TO 2), mf1FieldHelp$(1 TO n%), mf1Title$, mf1Prompt$,  _
  139. mf1ScrollFileSpec$(1 TO n%)
  140.   
  141.   
  142. 'don't get lost in video pages just yet
  143.    SCREEN , , 0, 0
  144.   
  145.    EditCustomerInfo
  146.   
  147.    EndProg
  148.   
  149.  
  150. REM $STATIC
  151.    SUB EditCustomerInfo
  152.      
  153.       filespec$ = "0001.dat"
  154.       GetLinesInFile filespec$, n%
  155.       n% = n% - 15   'don't count the file "header" as field items
  156.      
  157. 'field information is stored in data files to save memory
  158.      
  159.       filenum% = FREEFILE
  160.       OPEN filespec$ FOR INPUT AS filenum%
  161.      
  162.       FOR p2% = 1 TO 15         ''trash the file comments
  163.          LINE INPUT #1, trash$
  164.       NEXT p2%
  165.      
  166.       FOR p1% = 1 TO n%         'read the comma delimited data from the file
  167.          INPUT #1, t$, mf1FieldName$(p1%), mf1FieldHelp$(p1%), mf1FieldPos%(p1%, 1), mf1FieldPos%(p1%, 2), mf1FieldLen%(p1%), mf1FieldCap%(p1%), mf1FieldMask$(p1%, 1), mf1FieldMask$(p1%, 2), mf1ScrollFileSpec$(p1%)
  168.       NEXT p1%
  169.      
  170.       CLOSE filenum%
  171.      
  172.      
  173.      
  174. '--------------------------------------------------------------------------
  175. 'this stuff could also become part of the data file, but I got lazy <grin>
  176.      
  177.       mf1.edgeLine = 1
  178.       mf1.ulrow = 1
  179.       mf1.ulcol = 1
  180.       mf1.lrrow = 23
  181.       mf1.lrcol = 80
  182.       mf1.fgedge = cyan
  183.       mf1.bgedge = blue
  184.       mf1.fgbody = white
  185.       mf1.bgbody = black
  186.       mf1.fgtitle = yellow
  187.       mf1.bgtitle = blue
  188.       mf1.fgPrompt = yellow
  189.       mf1.bgPrompt = blue
  190.       mf1.fgNameActive = yellow
  191.       mf1.bgNameActive = red
  192.       mf1.fgNameInactive = green
  193.       mf1.bgNameInactive = black
  194.       mf1.fgValueActive = black
  195.       mf1.bgValueActive = white
  196.       mf1.fgValueInactive = cyan + bright
  197.       mf1.bgValueInactive = black
  198.       mf1.rowhelp = 25
  199.       mf1.fghelp = cyan + bright
  200.       mf1.bghelp = blue
  201.       mf1Title$ = " Enter Customer / Vehicle Information Below "
  202.       mf1Prompt$ = " TAB / SHIFT-TAB to move between fields ■ F10 when finished "
  203.      
  204.       CLS
  205.      
  206. 'This is it! After you've read the info from disk and set the other variables
  207. 'all you do is call this routine and input to your hearts content.
  208. 'Play with the colors above and see how easy it is to make it look different.
  209. 'Play with the data file "0001.dat", but don't get the comma delimited
  210. 'data out of place.
  211.      
  212.       MFI mf1, mf1FieldName$(), mf1FieldCap%(), mf1FieldValue$(), mf1FieldMask$(), mf1FieldLen%(), mf1FieldPos%(), mf1FieldHelp$(), mf1Title$, mf1Prompt$, mf1ScrollFileSpec$()
  213.      
  214.      
  215.       SCREEN , , 0, 0
  216.      
  217.    END SUB
  218.  
  219. DEFSNG A-Z
  220.    FUNCTION EdKeyCode% STATIC
  221.      
  222.       DO
  223.          k$ = INKEY$
  224.       LOOP UNTIL k$ <> ""
  225.       EdKeyCode% = CVI(k$ + CHR$(0))
  226.      
  227.      
  228.      
  229.    END FUNCTION
  230.  
  231. DEFINT A-Z
  232. '
  233.    SUB EndProg
  234.  
  235. 'whatever code you need to clean up after yourself goes in here too.
  236.      
  237.       SCREEN , , 0, 0
  238.       COLOR 7, 0
  239.       CLS
  240.       END
  241.      
  242.      
  243.    END SUB
  244.  
  245. '
  246.    SUB GetLinesInFile (filespec$, size%)
  247.      
  248.      
  249. '---------------------------------------------------------------------------
  250. '
  251. '  This sub finds the exact size for the array dimension so that no memory
  252. '  gets wasted. A little less than elegant, but I was in a hurry.
  253. '
  254. '---------------------------------------------------------------------------
  255.      
  256.      
  257.       filenum% = FREEFILE
  258.       OPEN filespec$ FOR INPUT AS filenum%
  259.      
  260.       size% = 0
  261.      
  262.       DO WHILE NOT EOF(filenum%)
  263.          size% = size% + 1
  264.          LINE INPUT #1, test$
  265.       LOOP
  266.      
  267.       CLOSE filenum%
  268.      
  269.      
  270.      
  271.    END SUB
  272.  
  273.    SUB Hold
  274.       DO UNTIL LEN(INKEY$): LOOP
  275.    END SUB
  276.  
  277. DEFSNG A-Z
  278.    FUNCTION KeyCode% STATIC
  279.      
  280.       KeyCode% = CVI(INKEY$ + STRING$(2, 0))
  281.      
  282.    END FUNCTION
  283.  
  284. DEFINT A-Z
  285. '****************************************************************************
  286. '        MultiFieldInputWindow - the ALL purpose input window
  287. '****************************************************************************
  288. '
  289. '  I would like to add the ability to pull up a scrollable select window
  290. '  to point and shoot values that will be plugged into the active field.
  291. '
  292. '
  293.    SUB MFI (mf AS MultiFieldType, mfFieldName$(), mfFieldCap%(), mfFieldValue$(), mfFieldMask$(), mfFieldLen%(), mfFieldPos(), mfFieldHelp$(), mfTitle$, mfPrompt$, mfScrollFileSpec$()) STATIC
  294.      
  295.      
  296.      
  297. 'Record current cursor location
  298.       cursorRow% = CSRLIN
  299.       cursorCol% = POS(0)
  300.      
  301. 'Determine current video page
  302.       CALL VideoState(mode%, columns%, page%)
  303.      
  304. 'window will be on next page if available
  305.       newpage% = page% + 1
  306.      
  307.       IF newpage% > 7 THEN
  308.          SCREEN , , 0, 0
  309.          PRINT "ERROR: MFI - not enough video pages"
  310.          SYSTEM
  311.       END IF
  312.      
  313. 'Copy current page to new page
  314.       PCOPY page%, newpage%
  315.      
  316. '---------------------------------------------------------------------------
  317. 'print to the apage while still looking at original vpage
  318.      
  319.       SCREEN , , newpage%, page%  'for "popping" the window onto the screen
  320.      
  321. 'after all the screen is printed to the not yet visible page, then make it visible
  322. 'SCREEN , , newpage%, newpage%   'finally make the new page visible
  323. '---------------------------------------------------------------------------
  324.      
  325. 'determine how many fields this MFI window has
  326.       lbField% = LBOUND(mfFieldName$)
  327.       ubField% = UBOUND(mfFieldName$)
  328.      
  329.      
  330. 'double check the array bounds - lbField% must be 1
  331.       IF lbField% <> 1 OR ubField% < 1 THEN
  332.          SCREEN , , 0, 0
  333.          PRINT "ERROR: MFI - text array dimensioned incorrectly"
  334.          SYSTEM
  335.       END IF
  336.      
  337. ' Check that MFI window is on screen
  338.      
  339.       IF mf.ulrow < 1 OR mf.ulcol < 1 OR mf.lrrow > 25 OR mf.lrcol > columns% THEN
  340.          SCREEN , , 0, 0
  341.          PRINT "Error: MFI - part of MFI window is off screen"
  342.          PRINT mf.ulrow, mf.ulcol, mf.lrrow, mf.lrcol, columns%
  343.          SYSTEM
  344.       END IF
  345.      
  346. 'determine the width and height of window to be displayed
  347.      
  348.       mfwidth% = mf.lrcol - mf.ulcol - 1
  349.       mfheight% = mf.lrrow - mf.ulrow
  350.      
  351. ' Set the edge characters
  352.      
  353.       SELECT CASE mf.edgeLine
  354.       CASE 0
  355.          ul% = 32
  356.          ur% = 32
  357.          ll% = 32
  358.          lr% = 32
  359.          vl% = 32
  360.          hl% = 32
  361.       CASE 1
  362.          ul% = 218
  363.          ur% = 191
  364.          ll% = 192
  365.          lr% = 217
  366.          vl% = 179
  367.          hl% = 196
  368.       CASE 2
  369.          ul% = 201
  370.          ur% = 187
  371.          ll% = 200
  372.          lr% = 188
  373.          vl% = 186
  374.          hl% = 205
  375.       CASE IS > 2
  376.          t% = mf.edgeLine
  377.          ul% = t%
  378.          ur% = t%
  379.          ll% = t%
  380.          lr% = t%
  381.          vl% = t%
  382.          hl% = t%
  383.       CASE ELSE
  384.          SCREEN , , 0, 0
  385.          PRINT "Error: MFI - Edge line type incorrect"
  386.          SYSTEM
  387.       END SELECT
  388.      
  389. ' Draw top edge of the box
  390.      
  391.       LOCATE mf.ulrow, mf.ulcol, 0
  392.       COLOR mf.fgedge, mf.bgedge
  393.       PRINT CHR$(ul%); STRING$(mfwidth%, hl%); CHR$(ur%);
  394.      
  395. ' Draw the body of the window
  396.      
  397.       FOR r% = mf.ulrow + 1 TO mf.lrrow - 1
  398.          LOCATE r%, mf.ulcol, 0
  399.          COLOR mf.fgedge, mf.bgedge
  400.          PRINT CHR$(vl%);
  401.          COLOR mf.fgbody, mf.bgbody
  402.         
  403.          tmp$ = SPACE$(mfwidth% - 2)
  404.          PRINT " "; tmp$; " ";
  405.         
  406.          COLOR mf.fgedge, mf.bgedge
  407.          PRINT CHR$(vl%);
  408.       NEXT r%
  409.      
  410. ' Draw bottom edge of the window box
  411.       LOCATE mf.lrrow, mf.ulcol, 0
  412.       COLOR mf.fgedge, mf.bgedge
  413.       PRINT CHR$(ll%); STRING$(mfwidth%, hl%); CHR$(lr%);
  414.      
  415. ' Center and print top title if present
  416.       IF mfTitle$ <> "" THEN
  417.          LOCATE mf.ulrow, (mf.ulcol + mf.lrcol - LEN(mfTitle$) + 1) \ 2, 0
  418.          COLOR mf.fgtitle, mf.bgtitle
  419.          PRINT mfTitle$;
  420.       END IF
  421.      
  422. ' Center and print prompt if present
  423.       IF mfPrompt$ <> "" THEN
  424.          LOCATE mf.lrrow, (mf.ulcol + mf.lrcol - LEN(mfPrompt$) + 1) \ 2, 0
  425.          COLOR mf.fgPrompt, mf.bgPrompt
  426.          PRINT mfPrompt$;
  427.       END IF
  428.      
  429. 'un-comment for double check of array boundries
  430. 'SetCursor mf.ulrow + 2, mf.ulcol + 2, 0, 7
  431. 'PRINT " LBOUND="; lbField%; " and UBOUND="; ubField%
  432. 'END
  433.      
  434.      
  435. 'get row, col, colors, etc. from variables and print
  436. 'field names in the Inactive colors so they're all visible
  437.      
  438.       FOR t% = 1 TO ubField%
  439.         
  440.          SetCursor mfFieldPos%(t%, 1), mfFieldPos%(t%, 2), mf.fgNameInactive, mf.bgNameInactive
  441.          PRINT mfFieldName$(t%);
  442.         
  443.          COLOR mf.fgValueInactive, mf.bgValueInactive
  444.         
  445. 'pad the fields with spaces
  446.          p$ = mfFieldValue$(t%) + STRING$(ABS(mfFieldLen%(t%)) - ABS(LEN(mfFieldValue$(t%))), 32)
  447.         
  448.          PRINT p$;
  449.         
  450.       NEXT t%
  451.      
  452. 'finally make the new page visible after it's ready to be displayed
  453.      
  454.       SCREEN , , newpage%, newpage%
  455.      
  456. '----------------------------------------------
  457. 'initiate a loop that does everything else.
  458.      
  459.      
  460.       ptr% = 1
  461.      
  462.       DO
  463.          IF ptr% > ubField% THEN ptr% = 1
  464.          IF ptr% = 0 THEN ptr% = ubField%
  465.         
  466.         
  467.          IF mf.rowhelp THEN     'pad the help line with spaces and print it
  468.             COLOR mf.fghelp, mf.bghelp
  469.             mfFieldHelp$(ptr%) = mfFieldHelp$(ptr%) + STRING$(80 - LEN(mfFieldHelp$(ptr%)), 32)
  470.             LOCATE mf.rowhelp, 1
  471.             PRINT mfFieldHelp$(ptr%);
  472.          END IF
  473.         
  474.          SetCursor mfFieldPos%(ptr%, 1), mfFieldPos%(ptr%, 2), mf.fgNameActive, mf.bgNameActive
  475.          PRINT mfFieldName$(ptr%);
  476.         
  477.         
  478.          mask$ = mfFieldMask$(ptr%, 1)
  479.          extramask$ = mf1FieldMask$(ptr%, 2)
  480.          exitcode% = mfFieldCap%(ptr%)          'set caps flag
  481.         
  482. wrongkey:
  483.         
  484. 'uncomment here for sending string length into editor for testing
  485. '         mfFieldValue$(ptr%) = LTRIM$(RTRIM$(STR$(mfFieldLen%(ptr%))))
  486.         
  487.          MFIedit mfFieldValue$(ptr%), mfFieldLen%(ptr%), mask$, extramask$, exitcode%, mf.fgValueActive, mf.bgValueActive
  488.         
  489.          SELECT CASE exitcode%
  490.          CASE CTRLEND
  491.             endflag% = TRUE
  492.          CASE CTRLHOME
  493.             homeflag% = TRUE
  494.          CASE TABKEY, ENTER, PGDN
  495.             direction% = 1
  496.          CASE SHIFTTABKEY, PGUP
  497.             direction% = 0
  498.          CASE F10
  499.             EXIT DO
  500.          CASE ELSE
  501.             GOTO wrongkey       ''go get another exitcode%
  502.          END SELECT
  503.         
  504.         
  505.         
  506.          SetCursor mfFieldPos%(ptr%, 1), mfFieldPos%(ptr%, 2), mf.fgNameInactive, mf.bgNameInactive
  507.          PRINT mfFieldName$(ptr%);
  508.         
  509.          COLOR mf.fgValueInactive, mf.bgValueInactive
  510.          PRINT mfFieldValue$(ptr%);
  511.         
  512.         
  513.         
  514.          SELECT CASE direction%
  515.          CASE 1
  516.             ptr% = ptr% + 1
  517.          CASE 0
  518.             ptr% = ptr% - 1
  519.          END SELECT
  520.         
  521.          IF homeflag% THEN ptr% = 1: homeflag% = FALSE
  522.          IF endflag% THEN ptr% = ubField%: endflag% = FALSE
  523.         
  524.         
  525.       LOOP
  526.      
  527.      
  528.    END SUB
  529.  
  530. '*****************************************************************************
  531. '  SUB MFIedit  (Multi Field Input Edit)
  532. '*****************************************************************************
  533. '
  534.    SUB MFIedit (a$, flen%, mask$, extramask$, exitcode%, fg%, bg%) STATIC       'keep all variables local
  535.      
  536.       IF flen% = 0 THEN flen% = LEN(a$)         'use space already allocated
  537.      
  538.      
  539. 'uncomment this line to show field lengths upon field entry for testing
  540. 'a$ = LTRIM$(RTRIM$(STR$(strlen%)))
  541.      
  542.      
  543.       clik% = 0
  544.       IF flen% < 0 THEN clik% = TRUE
  545.       strlen% = ABS(flen%)
  546.      
  547.      
  548. ''set up some variables
  549.       row% = CSRLIN
  550.       col% = POS(0)
  551.       length% = strlen%
  552.       ptr% = 0  ''position in the string to place the cursor to start out
  553.       inserton% = TRUE          ''default starts in insert mode
  554.       quit% = FALSE
  555.       original$ = a$
  556.       caps% = exitcode%
  557.      
  558.       accept$ = ""
  559.      
  560. 'mask specifiers
  561. '
  562. ' 1 - allkeys$
  563. ' 2 - number$
  564. ' 3 - c32$
  565. ' 4 - upperalpha$
  566. ' 5 - loweralpha$
  567. ' 6 - otherkeys$
  568. ' 7 - decimal$
  569.      
  570.       IF INSTR(mask$, "1") THEN accept$ = accept$ + allkeys$
  571.       IF INSTR(mask$, "2") THEN accept$ = accept$ + number$
  572.       IF INSTR(mask$, "3") THEN accept$ = accept$ + c32$
  573.       IF INSTR(mask$, "4") THEN accept$ = accept$ + upperalpha$
  574.       IF INSTR(mask$, "5") THEN accept$ = accept$ + loweralpha$
  575.       IF INSTR(mask$, "6") THEN accept$ = accept$ + otherkeys$
  576.       IF INSTR(mask$, "7") THEN accept$ = accept$ + decimal$
  577.      
  578.       IF INSTR(mask$, "c") THEN shortkeyclick% = TRUE
  579.       IF INSTR(mask$, "C") THEN longkeyclick% = TRUE
  580.      
  581.      
  582.       accept$ = accept$ + extramask$
  583.      
  584.       COLOR fg%, bg%
  585.      
  586. '''' ******* Main processing loop ********
  587.      
  588.       DO
  589.         
  590. 'Display the line
  591.          LOCATE row%, col%, 0
  592.          a$ = a$ + SPACE$(length% - LEN(a$))
  593.          PRINT a$;
  594.         
  595. 'Show appropriate cursor type
  596.         
  597.         
  598.          IF inserton% THEN
  599.             LOCATE row%, col% + ptr%, 1, 5, 7
  600.          ELSE
  601.             LOCATE row%, col% + ptr%, 1, 0, 7
  602.          END IF
  603.         
  604. 'Get next keystroke
  605.         
  606.         
  607. mfi0:
  608.         
  609.          keynumber% = EdKeyCode%
  610.         
  611.         
  612.         
  613. 'process the key
  614.          SELECT CASE keynumber%
  615.          CASE INSERTKEY
  616.             IF inserton% THEN
  617.                inserton% = FALSE
  618.             ELSE
  619.                inserton% = TRUE
  620.             END IF
  621.            
  622.          CASE BACKSPACE
  623.             IF ptr% THEN
  624.                a$ = a$ + " "
  625.                a$ = LEFT$(a$, ptr% - 1) + MID$(a$, ptr% + 1)
  626.                ptr% = ptr% - 1
  627.             END IF
  628.            
  629.          CASE DEL
  630.             a$ = a$ + " "
  631.             a$ = LEFT$(a$, ptr%) + MID$(a$, ptr% + 2)
  632.            
  633. 'CASE UPARROW  'these will be used in the scroll select routine
  634. '   exitcode% = UPARROW
  635. '   quit% = TRUE
  636.            
  637. 'CASE DOWNARROW
  638. '   exitcode% = DOWNARROW
  639. '   quit% = TRUE
  640.            
  641.          CASE LEFTARROW
  642.             IF ptr% THEN
  643.                ptr% = ptr% - 1
  644.             END IF
  645.            
  646.          CASE RIGHTARROW
  647.             IF ptr% < length% - 1 THEN
  648.                ptr% = ptr% + 1
  649.             END IF
  650.            
  651.          CASE ESCAPE
  652. 'exitcode% = ESCAPE
  653.             a$ = original$
  654.             quit% = FALSE
  655.            
  656.          CASE ENTER
  657.             exitcode% = ENTER
  658.             quit% = TRUE
  659.            
  660.          CASE SHIFTTABKEY
  661.             exitcode% = SHIFTTABKEY
  662.             quit% = TRUE
  663.            
  664.          CASE TABKEY
  665.             exitcode% = TABKEY
  666.             quit% = TRUE
  667.            
  668.          CASE CTRLHOME
  669.             exitcode% = CTRLHOME
  670.             quit% = TRUE
  671.            
  672.          CASE CTRLEND
  673.             exitcode% = CTRLEND
  674.             quit% = TRUE
  675.            
  676.          CASE F10               'change this value for other exit keys
  677.             exitcode% = F10
  678.             quit% = TRUE
  679.            
  680.          CASE PGUP
  681.             exitcode% = PGUP
  682.             quit% = TRUE
  683.            
  684.          CASE PGDN
  685.             exitcode% = PGDN
  686.             quit% = TRUE
  687.            
  688.          CASE HOME
  689.             ptr% = 0
  690.            
  691.          CASE ENDKEY
  692.             ptr% = length% - 1
  693.            
  694.          CASE CTRLRIGHTARROW
  695.             DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = length% - 1
  696.                ptr% = ptr% + 1
  697.             LOOP
  698.             DO UNTIL MID$(a$, ptr% + 1, 1) <> " " OR ptr% = length% - 1
  699.                ptr% = ptr% + 1
  700.             LOOP
  701.            
  702.          CASE CTRLLEFTARROW
  703.             DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = 0
  704.                ptr% = ptr% - 1
  705.             LOOP
  706.             DO UNTIL MID$(a$, ptr% + 1, 1) <> " " OR ptr% = 0
  707.                ptr% = ptr% - 1
  708.             LOOP
  709.             DO UNTIL MID$(a$, ptr% + 1, 1) = " " OR ptr% = 0
  710.                ptr% = ptr% - 1
  711.             LOOP
  712.             IF ptr% THEN
  713.                ptr% = ptr% + 1
  714.             END IF
  715.            
  716.          CASE CTRLY
  717.             a$ = SPACE$(length%)
  718.             ptr% = 0
  719.            
  720.          CASE CTRLQ
  721.             ctrlqflag% = TRUE
  722.            
  723.          CASE ESCAPE
  724.             a$ = original$
  725.             ptr% = 0
  726.             inserton% = TRUE
  727.            
  728.          CASE IS > 255
  729.             PLAY illegal$
  730.            
  731.          CASE IS < 32
  732.             PLAY illegal$
  733.            
  734.          CASE ELSE
  735.            
  736. 'convert key code to character string
  737.            
  738.             kee$ = CHR$(keynumber%)
  739.            
  740.             IF INSTR(accept$, kee$) THEN GOTO mfi2
  741.            
  742. mfi1:
  743.            
  744.             PLAY illegal$
  745.             GOTO mfi0
  746.            
  747.            
  748. mfi2:
  749.            
  750.             IF NOT quit% THEN
  751.                IF clik% THEN
  752.                   IF LEN(RTRIM$(LTRIM$(a$))) > strlen% THEN
  753.                      PLAY "t255 o3 g64o2c64o4g64o2c64o4g64o2c64"
  754.                   END IF
  755.                  
  756.                   PLAY click$
  757.                END IF
  758.             END IF
  759.            
  760.            
  761.            
  762. 'insert or overstrike
  763.             IF inserton% THEN
  764.                a$ = LEFT$(a$, ptr%) + kee$ + MID$(a$, ptr% + 1)
  765.                a$ = LEFT$(a$, length%)
  766.             ELSE
  767.                IF ptr% < length% THEN
  768.                   MID$(a$, ptr% + 1, 1) = kee$
  769.                END IF
  770.             END IF
  771.            
  772. 'are we up against the wall?
  773.             IF ptr% < length% THEN
  774.                ptr% = ptr% + 1
  775.             ELSE
  776.                PLAY fullfield$
  777.             END IF
  778.            
  779. 'special check for Ctrl-Q-Y (del to end of line)
  780.             IF kee$ = "y" AND ctrlqflag% THEN
  781.                IF ptr% <= length% THEN
  782.                   sp% = length% - ptr% + 1
  783.                   MID$(a$, ptr%, sp%) = SPACE$(sp%)
  784.                   ptr% = ptr% - 1
  785.                END IF
  786.             END IF
  787.            
  788.             IF caps% THEN       ''''if caps flag then auto capitalize the string
  789.                a$ = UCASE$(a$)
  790.             END IF
  791.            
  792. 'clear out ctrl-q signal
  793.             ctrlqflag% = FALSE
  794.            
  795.            
  796.          END SELECT
  797.         
  798.       LOOP UNTIL quit%
  799.      
  800.    END SUB
  801.  
  802. DEFSNG A-Z
  803. '*****************************************************************************
  804. '                       SUB - SetCursor
  805. '*****************************************************************************
  806. '
  807. '
  808.    SUB SetCursor (row%, col%, fc%, bc%)
  809.      
  810.       COLOR fc%, bc%
  811.      
  812.       LOCATE row%, col%, 0
  813.      
  814.    END SUB
  815.  
  816. '
  817.    SUB VideoState (mode%, columns%, page%) STATIC
  818.       DIM reg AS RegType
  819.       reg.ax = &HF00
  820.       INTERRUPT &H10, reg, reg
  821.       mode% = reg.ax AND &HFF
  822.       columns% = (CLNG(reg.ax) AND &HFF00) \ 256
  823.       page% = (CLNG(reg.bx) AND &HFF00) \ 256
  824.    END SUB
  825.  
  826.