[Back to ENTRY SWAG index] [Back to Main SWAG index] [Original]

    unit databox;

    { This is a unit to let you open data-entry boxes on the screen for quick 'n'
      easy data entry.  It operates on variables of type "string", "integer",
      "word", "byte", "longint" and "boolean".  There are two main routines to
      call here:

        OpenBox(x, y, data, temp, type) -- to open a data entry box on the screen
        ReadBoxes -- to read all data entry boxes

      The parameters for "OpenBox":
        x, y -- the coordinates where the box should appear on the screen
        data -- the variable you want to do data entry on
        type -- an character indicating what type of variable you're working on.
                Valid "types" are:

                'S' -- String            'I' -- Integer
                'W' -- Word              'L' -- LongInt
                'Y' -- Byte              'B' -- Boolean

        temp -- a string "template" indicating the size of the data entry
                field and the data acceptable at each position.  The following
                characters mean the following:

                'X' -- accept any character                 ( strings )
                '!' -- accept any character, but capitalize ( strings )
                '9' -- accept only digits and minus signs   ( numeric )
                'T' -- accept only 'T' and 'F'              ( boolean )
                'Y' -- accept only 'T', 'F', 'Y' and 'N'    ( boolean )

                All of these template characters are valid on strings.  For
                numeric fields, the whole template gets converted to all 9's;
                for boolean, the template will either be a single 'T' or 'Y'
                (it defaults to 'T').

        Examples:

          OpenBox(12, 10, counter, '99999', 'I');

          -- is for an integer variable "counter".  It opens a data entry box at
             position (12, 10), and is five characters across.

          OpenBox(1, 14, yes_or_no, 'Y', 'b')

          -- opens a data entry box for a boolean variable "yes_or_no", and will
             accept only a "Y" or an "N" as input.

          OpenBox(1, 25, namestring, '!XXXXXXXXXXXXXXXX', 's')

          -- opens a data entry box for a string variable "namestring"; it will
             automatically capitalize the first letter, and accept every other
             character entered "as is".

        When you have opened all your data boxes, call "ReadBoxes" to allow
        the user to actually input into the boxes.  Once you are done, the
        boxes "close" so you can't do any more data entry on them.  There is
        also a "ClearBoxes" procedure to manually "close" open boxes, and a
        "Qwrite" procedure for doing direct video writes.

        Oh, I'm Lou Duchez, and if you could leave my name somewhere in the
        code I'd appreciate it.  I'll never be rich off of public domain code
        like this, so at least help me get famous ...
      }
    {
    -------------------------------------------------------
    }
    interface

    const boxforeground: byte = 1;
          boxbackground: byte = 7;

    procedure qwrite(x, y: byte; s: string; f, b: byte);
    procedure openbox(x, y: byte; var data; template: string; datatype: char);
    procedure clearboxes;
    procedure readboxes;
    {
    -------------------------------------------------------
    }
    implementation
    uses crt;       { for "checkbreak" and "readkey" functions }

    const maxboxes = 255;     { open up to 255 data boxes simultaneously }

    type boxrecord = record   { holds all the data we need }
         x, y: byte;          { position to display on screen }
         template: string;    { describes size and type of data field }
         dataptr: pointer;    { points to data }
         datatype: char;      { type of data we're pointing to }
         end;

    var boxes: array[1 .. maxboxes] of ^boxrecord;  { all the data boxes }
        boxcount, thisbox, boxpos, boxlength: byte;
        boxstring: string;
        boxmodified: boolean;
    {
    -------------------------------------------------------
    }
    procedure qwrite(x, y: byte; s: string; f, b: byte);  { direct video writes }

    { x, y: coordinates to display string at }
    { s: the string to display }
    { f, b: the foreground and background colors to display in }

    type  videolocation = record           { video memory locations }
            videodata: char;               { character displayed }
            videoattribute: byte;          { attributes }
            end;

    var cnter: byte;
        videosegment: word;
        vidptr: ^videolocation;
        videomode: byte absolute $0040:$0049;
        scrncols: byte absolute $0040:$004a;
        monosystem: boolean;
    begin

    { Find the memory location where the string will be displayed at, according to
      the monitor type and screen location.  Then associate the pointer VIDPTR with
      that memory location: VIDPTR is a pointer to type VIDEOLOCATION.  Insert the
      screen data and attribute; now go to the next character and video location. }

      monosystem := (videomode = 7);
      if monosystem then videosegment := $b000 else videosegment := $b800;
      vidptr := ptr(videosegment, 2*(scrncols*(y - 1) + (x - 1)));
      for cnter := 1 to length(s) do begin
        vidptr^.videoattribute := (b shl 4) + f;
        vidptr^.videodata := s[cnter];
        inc(vidptr);
        end;
      end;
    {
    -------------------------------------------------------
    }
    procedure movecursor(boxnum, position: byte);          { Positions cursor. }
    var tmpx, tmpy: byte;
    begin
      tmpx := (boxes[boxnum]^.x - 1) + (position - 1);
      tmpy := (boxes[boxnum]^.y - 1);
      asm
        mov ah, 02h           { Move cursor here.  I don't use GOTOXY because it }
        mov bh, 00h           { is window-dependent. }
        mov dh, tmpy
        mov dl, tmpx
        int 10h
        end;
      end;
    {
    -------------------------------------------------------
    }
    procedure openbox(x, y: byte; var data; template: string; datatype: char);
    var i: byte;
        datastring, tempstring: ^string;
    begin
      if boxcount < maxboxes then begin   { If we have room for another data }
        inc(boxcount);                    { box, allocate memory for it from }
        new(boxes[boxcount]);             { the heap and fill its fields. }
        boxes[boxcount]^.x := x;
        boxes[boxcount]^.y := y;
        boxes[boxcount]^.dataptr := @data;
        boxes[boxcount]^.template := template;
        boxes[boxcount]^.datatype := upcase(datatype);
        case upcase(datatype) of

        { "Fix" data entry template as needed.  Make sure the string data and
          the template are of the same length.  Numeric templates should consist
          of all 9's.  Boolean templates should be either 'Y' or 'T'. }

          'S': begin
                 datastring := boxes[boxcount]^.dataptr;
                 tempstring := addr(boxes[boxcount]^.template);
                 while length(datastring^) < length(tempstring^) do
                       datastring^ := datastring^ + ' ';
                 while length(tempstring^) < length(datastring^) do
                       tempstring^ := tempstring^ + ' ';
                 end;
          'W', 'I', 'L', 'Y': for i := 1 to length(template) do
                              boxes[boxcount]^.template[i] := '9';
          'B': begin
                 boxes[boxcount]^.template[0] := #1;
                 if not (boxes[boxcount]^.template[1] in ['Y', 'T']) then
                    boxes[boxcount]^.template := 'T';
                 end;
          end;
        end;
      end;
    {
    -------------------------------------------------------
    }
    procedure clearboxes;           { Free up all memory for "box" data. }
    begin
      while boxcount > 0 do begin
        dispose(boxes[boxcount]);
        dec(boxcount);
        end;
      end;
    {
    -------------------------------------------------------
    }
    procedure fixstring(boxnumber: byte);   { Adjusts string for displaying }
    var i: byte;                            { so that each character adheres to }
    begin                                   { the corresponding template char. }
      for i := 1 to length(boxstring) do
        case upcase(boxes[boxnumber]^.template[i]) of
          'X': ;
          '!': boxstring[i] := upcase(boxstring[i]);
          '9': if not (boxstring[i] in ['-', '0' .. '9']) then boxstring[i] := ' ';
          'T': case upcase(boxstring[i]) of
               'Y', 'T': boxstring[i] := 'T';
               'N', 'F': boxstring[i] := 'F';
               else boxstring[i] := ' ';
               end;
          'Y': case upcase(boxstring[i]) of
               'Y', 'T': boxstring[i] := 'Y';
               'N', 'F': boxstring[i] := 'N';
               else boxstring[i] := ' ';
               end;
          end;
      qwrite(boxes[boxnumber]^.x, boxes[boxnumber]^.y, boxstring,
             boxforeground, boxbackground);
      end;
    {
    -------------------------------------------------------
    }
    procedure displaybox(boxnumber: byte); { Convert data to string and display. }
    var lentemplate: byte;
        pntr: pointer;
    begin
      pntr := boxes[boxnumber]^.dataptr;
      lentemplate := length(boxes[boxnumber]^.template);
      case boxes[boxnumber]^.datatype of
        'S':  boxstring := string(pntr^);
        'I':  str(integer(pntr^): lentemplate, boxstring);
        'W':  str(word(pntr^):    lentemplate, boxstring);
        'Y':  str(byte(pntr^):    lentemplate, boxstring);
        'L':  str(longint(pntr^): lentemplate, boxstring);
        'B':  if boolean(pntr^) then boxstring := 'T' else boxstring := 'F';
        end;
        fixstring(boxnumber);
      end;
    {
    -------------------------------------------------------
    }
    procedure deletekey;    { delete: remove character at cursor and shift over }
    var i: byte;
    begin
      boxmodified := true;
      for i := boxpos to boxlength - 1 do  boxstring[i] := boxstring[i + 1];
      boxstring[boxlength] := ' ';
      end;

    procedure backspace;        { backspace: back up one and delete if we're }
    begin                       { still in the same box }
      boxpos := boxpos - 1;
      if boxpos = 0 then begin
        dec(thisbox);
        boxpos := 255;
        end
       else deletekey;
      end;

    { Enter, Tab, and Shift-Tab move you to the beginning of prev/next box }

    procedure enterkey;   begin inc(thisbox); boxpos := 1; end;
    procedure tab;        begin inc(thisbox); boxpos := 1; end;
    procedure reversetab; begin dec(thisbox); boxpos := 1; end;

    { PgUp, PgDn, Esc take you out of editing; "Esc" indicates that the
      "current" box should not be updated }

    procedure pageup;     begin thisbox := 0; end;
    procedure pagedown;   begin thisbox := 0; end;
    procedure esckey;     begin thisbox := 0; boxmodified := false; end;

    { Up / Down }

    procedure moveup;     begin dec(thisbox); end;
    procedure movedown;   begin inc(thisbox); end;

    procedure moveleft;   { Move left; if we go too far left, move up }
    begin
      dec(boxpos);
      if (boxpos = 0) then begin
        boxpos := 255;
        moveup;
        end;
      end;

    procedure moveright;  { Move right; if we go too far right, move down }
    begin
      inc(boxpos);
      if (boxpos > boxlength) then begin
        boxpos := 1;
        movedown;
        end;
      end;

    procedure literalkey(keyin: char);  { accept character into field }
    var i: byte;
        goodkey, insmode: boolean;
        keyboardstat: byte absolute $0040:$0017;
    begin
      case upcase(boxes[thisbox]^.template[boxpos]) of   { does char match tmplt? }
        '9': goodkey := (keyin in ['-', '0'..'9']);
        'T': goodkey := (upcase(keyin) in ['T', 'F']);
        'Y': goodkey := (upcase(keyin) in ['T', 'F', 'Y', 'N']);
        else goodkey := true;
        end;
      if goodkey then begin             { character matches template -- use it }
        boxmodified := true;
        insmode := (keyboardstat and $80 = $80);
        if insmode then begin
          i := length(boxstring);       { "Insert" mode: make space for new char }
          while i > boxpos do begin
            boxstring[i] := boxstring[i - 1];
            dec(i);
            end;
          end;
        boxstring[boxpos] := keyin;     { enter character and move to the right }
        moveright;
        end;
      end;
    {
    -------------------------------------------------------
    }
    procedure readbox;  { get data input on the box specified by THISBOX }
    var keyin: char;
        startingbox, i: byte;
        pntr: pointer;
        dummyint: integer;
        numstring: string;
    begin
      boxmodified := false;             { "housekeeping" here }
      startingbox := thisbox;
      displaybox(thisbox);
      boxlength := length(boxstring);
      if boxpos > boxlength then boxpos := boxlength;   { cursor positioning }
      if boxpos < 1 then boxpos := 1;
      while (thisbox = startingbox) and
            (boxpos >= 1) and (boxpos <= boxlength) do begin  { process field }
        fixstring(startingbox);
        movecursor(startingbox, boxpos);
        keyin := readkey;                         { Interpret keystrokes here }
        case keyin of
           #0:  case readkey of
                  #15:  reversetab;
                  #72:  moveup;
                  #73:  pageup;
                  #75:  moveleft;
                  #77:  moveright;
                  #80:  movedown;
                  #81:  pagedown;
                  #83:  deletekey;
                  end;
           #8:  backspace;
           #9:  tab;
          #13:  enterkey;
          #27:  esckey;
          else  literalkey(keyin);
          end;
        end;
      if boxmodified then begin       { If data was changed, update variable }

        { This section handles numeric decoding.  Since "Val" gets real uppity
          if there are spaces in the middle of your string, these couple loops
          isolates the first section of the data entry string surrounded by
          spaces.  Then "Val" processes that part. }

        i := 1;
        while (i <= length(boxstring)) and (boxstring[i] = ' ') do inc(i);
        numstring[0] := #0;
        while (i <= length(boxstring)) and (boxstring[i] <> ' ') do begin
          inc(numstring[0]);
          numstring[length(numstring)] := boxstring[i];
          inc(i);
          end;
        pntr := boxes[startingbox]^.dataptr;

        { Put the updated data back into its original variable. }

        case boxes[startingbox]^.datatype of
          'S': string(pntr^) := boxstring;
          'I': val(numstring, integer(pntr^), dummyint);
          'W': val(numstring, word(pntr^),    dummyint);
          'Y': val(numstring, byte(pntr^),    dummyint);
          'L': val(numstring, longint(pntr^), dummyint);
          'B': boolean(pntr^) := (upcase(boxstring[1]) = 'Y') or
                                 (upcase(boxstring[1]) = 'T');
          end;
        end;

      { Do a final data display. }

      displaybox(startingbox);
      movecursor(startingbox, boxlength + 1);
      end;
    {
    -------------------------------------------------------
    }
    procedure readboxes;          { gets data input on all boxes }
    var oldcheckbreak: boolean;
    begin
      oldcheckbreak := checkbreak;
      checkbreak := false;
      for thisbox := 1 to boxcount do displaybox(thisbox);  { display data boxes }
      thisbox := 1;
      boxpos := 1;
      while (thisbox >= 1) and (thisbox <= boxcount) do readbox;
      clearboxes;
      checkbreak := oldcheckbreak;
      end;
    {
    -------------------------------------------------------
    }
    begin               { initialize to "no boxes" }
      boxcount := 0;
      end.

    ==============================================================================
    TEST PROGRAM:
    ==============================================================================
    program datatest;
    uses databox, crt;

    var i: integer;    s: string;     w: word;
        b: boolean;    l: longint;    y: byte;

    begin
      clrscr;
      i := 10;              openbox(1, 1, i, '999999', 'i');
      w := 10;              openbox(1, 3, w, '999999', 'w');
      s := 'SpamBurger';    openbox(1, 5, s, '!xxxxxxxxxxxxxxx', 's');
      readboxes;
      gotoxy(1, 18);  writeln(i);  writeln(w);  writeln(s);

      b := false;           openbox(1, 7, b, 'Y', 'b');
      l := 10;              openbox(1, 9, l, '9999999999', 'l');
      y := 20;              openbox(1,11, y, '9999999999', 'y');
      readboxes;
      gotoxy(1, 21);  writeln(b);  writeln(l);  writeln(y);
      end.

[Back to ENTRY SWAG index] [Back to Main SWAG index] [Original]