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

    Unit KeybFAQ;
    (* This is version 0.90 of KEYBFAQ, a Unit that answers two questions
     * often asked in the Pascal message area's:
     * - How do I change my cursor ?
     * - How can I perform input of String With certain limitations
     *   (such as 'maximum length', 'only numbers' etc.)
     *
     * I will distribute this Unit *ONCE* in message form (three messages)
     * because it takes up 500 lines of code. It is untested code, cut from
     * my Unit library, and distributed *as is* With no other documentation
     * than these initial lines. You can use this code in your apps as you like,
     * and you can redistribute it, provided you:
     * - redistribute *source* code;
     * - do not Charge anything For the source code;
     * - give me credit For the original code if you change anything;
     * - keep this 'documentation' With it.
     * (Loosely translated: common decency is enough)
     * Copyright will formally remain mine.
     *
     * Please do not respond about this code. I am going away For a few weeks
     * and will distribute version 1.0 in ZIP form after that. That package
     * will have *tested* code, docs and examples.
     *
     * Some notes about this code:
     * - Use it always, or don't use it. I.e. if you start using GetKey
     *   you should use that throughout your Program, and drop all ReadKeys.
     * - The redefinition of Char into Key has two reasons:
     *   - it allows better Type checking
     *   - it allows future changes to the internal representation of the
     *     Key Type (I plan to make it a Word Type to handle the overlap
     *     in key definitions that is still present, and/or adapt Unicode
     *     Character definitions)
     * - The overlap in the Constant key definitions may look
     *   problematic, but in the years I have been using this, it has not
     *   posed any problems, generally because you only allow those keys
     *   that have a meaning For your app.
     *
     * Happy Pascalling,
     * Jan Doggen, 27/8/93 *)

    Interface

    Type
      Key    = Char;
      KeySet = Set of Key;
      (* See later in this Interface section For defined sets *)

    Var
      BlankChar : Char;    (* Char used by GetStr to fill the bar; default ' ' *)

    Procedure FlushKeyBuf;
    (* Clears the BIOS keyboard buffer *)

    Function  InsertStatus : Boolean;
    Procedure SetInsertStatus(On : Boolean);

    Procedure NiceBeep;
    (* Replaces the system beep With a more pleasant one. *)

    Type
      CursType = (NOCUR, LINECUR, BLOCKCUR);

    Procedure SetCursor(CType: CursType);
    (* SetCursor sets a block or line cursor, or no cursor. *)

    Function GetVidMode : Byte;
    (* Return BIOS video mode *)

    Function MonoChrome(Vmode : Byte) : Boolean;
    (* Returns True if a monochrome video mode is specified *)

    Function WinLeft   : Byte;
    Function WinRight  : Byte;
    Function WinTop    : Byte;
    Function WinBottom : Byte;
    (* Return Absolute co-ordinates of current Window *)

    Function RepeatStr(Str : String; N : Integer) : String;
    (* Returns a String consisting of <N> repetitionsof <Str>. *)

    Function GetKey : Key;
    (* Returns a Variable of Type Key; see the table below For the definitions.
     * GetKey also accepts the <Alt-numeric keypad> ASCII codes. *)

    Var
      ClearOnFirstChar,
      WalkOut,
      StartInFront : Boolean;
     (* These Booleans influence the way in which GetStr operates:
      *
      * With WalkOut = True: the left and right arrow keys also act as ExitKeys
      * when they bring us 'outside' of the Word (we Exit the Procedure).
      *
      * With ClearOnFirstChar = True: if the first key Typed is a Character,
      * the initial Str is cleared.
      *
      * With StartInFront = True: the cursor will be positioned at the first
      * Character when we start the Procedure (instead of after the last)
      *
      * Default settings For these Booleans are False. *)

    Procedure GetStr(Xpos, Ypos,
                     MaxLen,
                     Ink, Paper   : Byte;
                     AllowedKeys,
                     ExitKeys     : KeySet;
                     BeepOnError  : Boolean;
                     Var Str      : String;
                     Var ExitKey  : Key);
    (* Reads a String of max. <MaxLen> Characters starting at relative position
     * <XPos,YPos>. A bar of length <MaxLen> is placed there With colors
     * <Ink> on <Paper>. An initial value For the String returned can be
     * passed With <Str>.
     *
     * - BeepOnError indicates audio feedback on incorrect keypresses
     * - AllowedKeys is a set of Keys that may be entered. if AllowedKeys = [],
     *   all keys are allowed.
     * - ExitKeys is a set of Keys that stop the Procedure; <Str> will then
     *   contain the edited String and <ExitKey> will be key that made us Exit.
     *   if ExitKeys is [], it will be replaced by [Enter,Escape].
     *   The keys you specify in ExitKeys, do not have to be specified in
     *   AllowedKeys. *)

    Function WaitKey(LegalKeys : Keyset; Flush : Boolean) : Key;
    (* Waits For one of the keys in LegalKeys to be pressed, then returns this.
     * if <Flush> = True, the keyboard buffer is flushed first. *)

    Const
      Null      = #0;    CtrlA = #1;   F1       = #187;  Home       = #199;
      BSpace    = #8;    CtrlB = #2;   F2       = #188;  endKey     = #207;
      Tab       = #9;    CtrlC = #3;   F3       = #189;  PgUp       = #201;
      Lfeed     = #10;   CtrlD = #4;   F4       = #190;  PgDn       = #209;
      Ffeed     = #12;   CtrlE = #5;   F5       = #191;  Left       = #203;
      CReturn   = #13;   CtrlF = #6;   F6       = #192;  Right      = #205;
      Escape    = #27;   CtrlG = #7;   F7       = #193;  Up         = #200;
      ShiftTab  = #143;  CtrlH = #8;   F8       = #194;  Down       = #208;
      CtrlPrtsc = #242;  CtrlI = #9;   F9       = #195;  Ins        = #210;
      Enter     = #13;   CtrlJ = #10;  F10      = #196;  Del        = #211;
      Esc       = #27;   CtrlK = #11;  ShiftF1  = #212;  CtrlLeft   = #243;
      Space     = #32;   CtrlL = #12;  ShiftF2  = #213;  CtrlRight  = #244;
                         CtrlM = #13;  ShiftF3  = #214;  CtrlendKey = #245;
      { Note the     }   CtrlN = #14;  ShiftF4  = #215;  CtrlPgdn   = #246;
      { overlap of   }   CtrlO = #15;  ShiftF5  = #216;  CtrlPgup   = #127;
      { Ctrl-keys    }   CtrlP = #16;  ShiftF6  = #217;  CtrlHome   = #247;
      { and others ! }   CtrlQ = #17;  ShiftF7  = #218;
                         CtrlR = #18;  ShiftF8  = #219;
                         CtrlS = #19;  ShiftF9  = #220;
                         CtrlT = #20;  ShiftF10 = #221;
                         CtrlU = #21;  CtrlF1   = #222;
                         CtrlV = #22;  CtrlF2   = #223;
                         CtrlW = #23;  CtrlF3   = #224;
                         CtrlX = #24;  CtrlF4   = #225;
                         CtrlY = #25;  CtrlF5   = #226;
                         CtrlZ = #26;  CtrlF6   = #227;
                         AltQ  = #144; CtrlF7   = #228;
                         AltW  = #145; CtrlF8   = #229;
                         AltE  = #146; CtrlF9   = #230;
                         AltR  = #147; CtrlF10  = #231;
                         AltT  = #148; AltF1    = #232;
                         AltY  = #149; AltF2    = #233;
                         AltU  = #150; AltF3    = #234;
                         AltI  = #151; AltF4    = #235;
                         AltO  = #152; AltF5    = #236;
                         AltP  = #153; AltF6    = #237;
                         AltA  = #158; AltF7    = #238;
                         AltS  = #159; AltF8    = #239;
                         AltD  = #160; AltF9    = #240;
                         AltF  = #161; AltF10   = #241;
                         AltG  = #162;
                         AltH  = #163;
                         AltJ  = #164;
                         AltK  = #165;
                         AltL  = #166; Alt1     = #248;
                         AltZ  = #172; Alt2     = #249;
                         AltX  = #173; Alt3     = #250;
                         AltC  = #174; Alt4     = #251;
                         AltV  = #175; Alt5     = #252;
                         AltB  = #176; Alt6     = #253;
                         AltN  = #177; Alt7     = #254;
                         AltM  = #178; Alt8     = #255;  { No Alt9 or Alt0 ! }

    { SETS }
      LetterKeys   : KeySet = ['A'..'Z','a'..'z'];
      SpecialKeys  : KeySet =
        ['!','?','b','a','a','a','a','a','A','a','A','A','e','e','e',
         'e','E','i','i','i','i','o','o','o','o','o','O','u','u','u',
         'u','U','c','C','n','N'];
      UpKeys       : KeySet = ['A'..'Z'];
      LowKeys      : KeySet = ['a'..'z'];
      VowelKeys    : KeySet = ['a','e','i','o','u','A','E','I','O','U'];
      DigitKeys    : KeySet = ['0'..'9'];
      OperatorKeys : KeySet = ['*','/','+','-'];
      YNKeys       : KeySet = ['y','n','Y','N'];
      JNKeys       : KeySet = ['j','n','J','N'];
      BlankKeys    : KeySet = [#0..#32];
      AllKeys      : KeySet = [#0..#255];
      FKeys        : KeySet = [F1..F10];
      ShiftFKeys   : KeySet = [ShiftF1..ShiftF10];
      AltFKeys     : KeySet = [AltF1..AltF10];
      CtrlFKeys    : KeySet = [CtrlF1..CtrlF10];
      AllFKeys     : KeySet = [F1..F10,ShiftF1..AltF10];

    Implementation

    Uses Crt,Dos;

    Procedure NiceBeep; (* Replaces the system beep With a more pleasant one. *)
    begin
      Sound(300);
      Delay(15);
      NoSound;
    end;

    Procedure FlushKeyBuf;
    Var
      Ch : Char;
    begin
      While KeyPressed do
        Ch := ReadKey;
    end;

    Function InsertStatus : Boolean;
    Var
      Regs : Registers;
    begin
      Regs.AH := 2;
      Intr($16, Regs);
      InsertStatus := ((Regs.AL and 128) = 128);
    end;

    Procedure SetInsertStatus(On: Boolean);
    begin
      if ON then
        Mem[$0040:$0017] := Mem[$0040:$0017] or 128
      else
        Mem[$0040:$0017] := Mem[$0040:$0017] and 127;
    end;

    Function GetVidMode: Byte;
    Var
      Regs : Registers;
    begin
      Regs.AH := $0F;
      Intr($10, Regs);
      GetVidMode := Regs.AL;
    end;

    Function MonoChrome(Vmode : Byte) : Boolean;
    begin
      MonoChrome := (VMode in [0,2,5,6,7,15,17]);
    end;

    Function WinLeft : Byte;
    begin
      WinLeft := Lo(WindMin) + 1;
    end;

    Function WinRight : Byte;
    begin
      WinRight := Lo(WindMax) + 1;
    end;

    Function WinTop : Byte;
    begin
      WinTop := Hi(WindMin) + 1;
    end;

    Function WinBottom : Byte;
    begin
      WinBottom := Hi(WindMax) + 1;
    end;

    Function RepeatStr(Str : String; N : Integer) : String;
    Var
      Result : String;
      I, J,
      NewLen,
      Len    : Integer;
    begin
      Len    := Length(Str);
      NewLen := N * Length(Str);
      Result[0] := Chr(NewLen);
      J := 1;
      For I := 1 to N DO
      begin
        Move(Str[1], Result[J], Len);
        Inc(J, Len);
      end;
      RepeatStr := Result;
    end;

    Procedure SetCursor(CType : CursType);
    Var
      VM   : Byte;
      Regs : Registers;
    begin
      VM := GetVidMode;
      With Regs DO
      Case CType OF
        NOCUR :
        begin
          Regs.CX := $2000;      { Off-screen cursor position }
          Regs.AH := 1;
        end;

        LINECUR : begin
          AX := $0100;
          BX := $0000;
          if MonoChrome(VM) then
            CX := $0B0C
          else
            CX := $0607
        end;

        BLOCKCUR :
        begin
          AX := $0100;
          BX := $0000;
          if MonoChrome(VM) then
            CX := $010D
          else
            CX := $0107;
        end;
      end;
      Intr($10, Regs);
    end;

    Function GetKey : Key;
    Var
      Ch : Char;
    begin
      Ch := ReadKey;
      if Ch = #0 then
      begin
        Ch := ReadKey;
        if Ch <= #127 then
          GetKey := Chr(Ord(Ch) or $80)
        else
        if Ch = #132 then
          GetKey := CtrlPgUp
        else
          GetKey := Null;
      end
      else
        GetKey := Ch;
    end;

    Procedure GetStr(XPos, YPos, MaxLen, Ink, Paper : Byte; AllowedKeys,
                     ExitKeys : KeySet; BeepOnError : Boolean;
                     Var Str : String; Var ExitKey : Key);
    Var
      CursPos,
      LeftPos,
      TopPos,
      RightPos,
      BottomPos,
      X, Y        : ShortInt;
      InsFlag,
      OAFlag,
      FirstKey    : Boolean;
      InKey       : Key;
      OldTextAttr : Byte;
      OldWindMin,
      OldWindMax  : Word;

      Procedure CleanUp;
      { Second level; called when we leave }
      begin
        WindMin  := OldWindMin;
        WindMax  := OldWindMax;
        TextAttr := OldTextAttr;
        ExitKey  := InKey;
      end;

    begin
      LeftPos   := WinLeft;
      RightPos  := WinRight;
      TopPos    := WinTop;
      BottomPos := WinBottom;
      X         := XPos + LeftPos - 1;
      Y         := YPos + TopPos - 1;
      InsFlag   := InsertStatus;
      if ExitKeys = [] then
        ExitKeys := [Enter, Escape];
      if AllowedKeys = [] then
        AllowedKeys := AllKeys;
     (* Save old settings here; restore them in proc CleanUp when Exiting *)
      OldWindMin := WindMin;
      OldWindMax := WindMax;
      WindMin := 0;             { Set Absolute Window co-ordinates and     }
      WindMax := $FFFF;         { prevent scroll at lower right Character. }
      OldTextAttr := TextAttr;
      TextAttr := ((Paper SHL 4) or Ink) and $7F;
      { Note: the 'AND $F' ensures that blink is off }
      if StartInFront then
        CursPos := 1
      else
      if Length(Str)+1 < MaxLen then
        CursPos := Length(Str) + 1
      else
        CursPos := MaxLen;
      FirstKey := True;
      if InsFlag then
        SetCursor(BLOCKCUR)
      else
        SetCursor(LINECUR);
      Repeat
        if CursPos < 1 then
          if WalkOut then
          begin
            CleanUp;
            Exit;
          end
          else
          if BeepOnError then
          begin
            NiceBeep;
            CursPos := 1;
          end;

        if (CursPos > Length(Str) + 1) then
          if WalkOut then
          begin
            CleanUp;
            Exit;
          end
          else
          if BeepOnError then
          begin
            NiceBeep;
            CursPos := Length(Str) + 1;
          end;

        if CursPos > MaxLen then
          if WalkOut and (InKey = Right) then
          begin
            CleanUp;
            Exit;
          end
          else
          begin
            if BeepOnError then
              NiceBeep;
            CursPos := MaxLen;
          end;

        GotoXY(X, Y);
        Write(Str + RepeatStr(BlankChar, MaxLen - Length(Str)));
        GotoXY(X + CursPos - 1, Y);
        InKey := GetKey;

        if InKey in ExitKeys then
        begin
          CleanUp;
          Exit;
        end;

        Case InKey OF
          Left              : Dec(CursPos);
          Right             : Inc(CursPos);
          CtrlLeft, Home    : CursPos := 1;
          CtrlRight, endKey : CursPos := Length(Str) + 1;
          Tab               : Inc(CursPos,8);
          ShiftTab          : Dec(CursPos,8);

          Ins :
          begin
            InsFlag := not InsFlag;
            if InsFlag then
              SetCursor(BLOCKCUR)
            else
              SetCursor(LINECUR);
          end;

          Del :
          if CursPos > Length(Str) then
          begin
            if BeepOnError then
              NiceBeep;
          end
          else
            Delete(Str, CursPos, 1);

          BSpace :
          if CursPos = 1 then
            if Length(Str) = 1 then
              Str := ''
            else
            begin
              if BeepOnError then
                NiceBeep;
            end
            else
            begin
              Delete(Str, CursPos - 1, 1);
              Dec(CursPos);
            end;
          else
          begin
            (* Note that 'AllowedKeys' that also have a
            * meaning as a control key have already been
            * processed, so they will not be handled here. *)
            if InKey in AllowedKeys then
            begin
              if ClearOnFirstChar and FirstKey then
              begin
                Str     := '';
                CursPos := 1;
              end;
              if (CursPos = MaxLen) then
              begin
                Str[CursPos] := InKey;
                Str[0]       := Chr(MaxLen);
              end
              else
              if InsFlag then
              begin
                Insert(InKey,Str,CursPos);
                if Length(Str) > MaxLen then
                  Str[0] := Chr(MaxLen);
              end
              else
              begin
                Str[CursPos] := InKey;
                if CursPos > Length(Str) then
                  Str[0] := Chr(CursPos);
              end;

              Inc(CursPos);
            end
            else
            if BeepOnError then
              NiceBeep;
          end;
        end;

        FirstKey := False;
      Until 0 = 1;
    end;

    Function WaitKey(LegalKeys : Keyset; Flush : Boolean) : Key;
    Var
      K : Key;
    begin
      if Flush then
        FlushKeybuf;
      Repeat
        K := GetKey;
      Until K in LegalKeys;
      WaitKey := K;
    end;

    begin
      BlankChar        := ' ';
      WalkOut          := False;
      ClearOnFirstChar := False;
      StartInFront     := False;
    end.

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