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

    { This is a big one... This is an (hopefully) error free, full featured, date
    input routine. It accepts all known editing keys (such as left, right, del, bs
    etc,etc,etc...) and validates the inserted date. Well, the parameters are:

              data(x,y:integer;ct:boolean; var inp:string; var ret:integer);

              (x,y) - coordinates of input location;
              ct    - is insert on (true) or off (false);
              inp   - where the new date will be inserted;
              ret   - return code. 1 means up was pressed, 2 means down pressed;
                      0 means esc was pressed. Any of these abort date entry,
                      although that can be easily fixed by deactivating their
                      entries in the datainput procedure;

    Dates get out in the European DD/MM/YY format. This only afects the validation,
    so if you want to change it, change the order of x1, x2 and x3 in vali_date to
    suit your needs. For instance, to get the format MM/DD/YY, change all x1 in the
    val functions to x2, and all x2 to x1. ONLY IN THE VAL, in the beggining of the
    vali_date procedure.

    Portuguese Freeware, 1994, Luis Evaristo Fonseca Thunderball Software Inc.
    }

    unit dateinp;

    interface

    uses crt,top;

    const
        BS        =   8;
        TAB       =   9;
        CR        =  13;
        CTRLT     =  20;
        CTRLY     =  25;
        ESC       =  27;
        HOME      = 327;
        UP        = 328;
        ENDK
        DOWN      = 336;
        LEFT      = 331;
        RIGHT     = 333;
        INS       = 338;
        DEL       = 339;
        CTRLLEFT  = 371;
        CTRLRIGHT = 372;
        ONLYNUM=['0'..'9'];

    procedure data(x,y:integer;ct:boolean; var inp:string; var ret:integer);

    IMPLEMENTATION

    { l� tecla premida }
    function getkey : word;
    var
        ch : char;
    begin
        ch := readkey;
        if ch=#0 then
            getkey := ord(readkey)+256
        else
            getkey := ord(ch);
    end;

    { escreve a string no �cran }
    procedure writestr(x,y:integer;inp:string;var x1:integer);
    var aux,conta:integer;
    begin
        gotoxy(x,y);
        write('  /  /  ');
        gotoxy(x,y);
        aux:=x;
        for conta:=1 to ord(inp[0]) do
        begin
            case conta of
                1,2:begin
                        gotoxy(x+conta-1,y);
                        write(inp[conta]);
                    end;
                3,4:begin
                        gotoxy(x+conta,y);
                        write(inp[conta]);
                    end;
                5,6:begin
                        gotoxy(x+conta+1,y);
                        write(inp[conta]);
                    end;
            end;
        end;
        gotoxy(x1,y);
    end;

    { salta para a primeira posi��o de cursor v�lida, actualiza �cran }
    procedure homekey(x,y:integer; var x1,posic:integer);
    begin
        x1:=x;
        posic:=1;
        gotoxy(x1,y);
    end;

    { salta para a £ltima posi�Æo de cursor utilizada, actualiza �cran }
    procedure endkey(inp:string;x,y:integer;var x1,posic:integer);
    begin
        case length(inp) of
            1:x1:=x+1;
            2:x1:=x+3;
            3:x1:=x+4;
            4:x1:=x+6;
            5:x1:=x+7;
            6:x1:=x+7;
        end;
        posic:=length(inp)+1;
        if posic>6 then
            posic:=6;
        gotoxy(x1,y);
    end;

    { move o cursor uma casa para a esquerda, actualiza �cran, n�o ultrapassa o }
    { limite m�ximo de cursor � esquerda }
    procedure leftkey(x,y:integer; var x1,posic:integer);
    begin
        x1:=x1-1;
        posic:=posic-1;
        if (x1=x+2) or (x1=x+5) then
            x1:=x1-1;
        if x1-x<0 then
        begin
            x1:=x1+1;
            posic:=posic+1;
        end;
        gotoxy(x1,y);
    end;

    { move o cursor uma casa para a direita, actualiza �cran, nÆo ultrapassa a }
    { posi�Æo do £ltimo caracter escrito mais uma posi�Æo }
    procedure rightkey(x,y:integer; inp:string; var x1,posic:integer);
    begin
        x1:=x1+1;
        posic:=posic+1;
        if (x1=x+2)  or (x1=x+5) then
            x1:=x1+1;
        if (length(inp)+1<posic) or (x1>x+7) then
        begin
            x1:=x1-1;
            posic:=posic-1;
        end;
        gotoxy(x1,y);
    end;

    { move o cursor para a primeira letra da palavra, ou (caso }
    { o cursor nÆo se encontre sobre nenhuma palavra, a pr¢xima }
    procedure ctrll(x,y:integer; inp:string; var x1,posic:integer);
    begin
        if posic<4 then
        begin
            posic:=1;
            x1:=x;
        end
        else
        begin
            posic:=3;
            x1:=x+3;
        end;
        gotoxy(x1,y);
    end;

    { move o cursor para a primeira letra da palavra seguinte }
    procedure ctrlr(x,y:integer; inp:string; var x1,posic:integer);
    begin
        case posic of
            1,2:if length(inp)>1 then
                begin
                    posic:=3;
                    x1:=x+3;
                end;
            3,4:if length(inp)>3 then
                begin
                    posic:=5;
                    x1:=x+6;
                end;
        end;
        gotoxy(x1,y);
    end;

    { apaga tudo o que est� escrito, actualiza string e ecran }
    procedure ctrl_y(x,y:integer; var x1,posic:integer; var inp:string);
    begin
        x1:=x;
        posic:=1;
        inp:='';
        writestr(x,y,inp,x1);
    end;

    { apaga tudo o que est� escrito � direita do cursor, actualiza string e ecran }
    procedure ctrl_t(x,y:integer; var x1,posic:integer; var inp:string);
    var conta:integer;
    begin
        if length(inp)>posic then
            for conta:=posic to length(inp) do
                delete(inp,posic,1);
        writestr(x,y,inp,x1);
    end;

    { liga / desliga o modo de inser��o "overwrite" (cursor em bloco) ou normal }
    procedure inskey(var ct:boolean);
    begin
        if ct=true then
        begin
            bigcursor;
            ct:=false
        end
        else
        begin
            linecursor;
            ct:=true;
        end;
    end;

    { apaga o caracter � direita na string, actualiza �cran }
    procedure delk(x,y:integer;var x1,posic:integer;var inp:string);
    begin
        if length(inp)>=posic then
            delete(inp,posic,1);
        writestr(x,y,inp,x1);
    end;

    { apaga o caracter � esquerda na string, actualiza �cran, nÆo passa o }
    { limite m�ximo � esquerda }
    procedure bsk(x,y:integer;var x1,posic:integer;var inp:string);
    begin
        if x1-1>=x then
        begin
             delete(inp,posic-1,1);
             if (posic in [3,5]) then
                 x1:=x1-2
             else
                 x1:=x1-1;
             posic:=posic-1;
             writestr(x,y,inp,x1);
        end;
    end;

    procedure tabkey(x,y:integer;ct:boolean;var x1,posic:integer;var inp:string);
    var conta:integer;
    begin
        case posic of
            1,2:if length(inp)>1 then
                begin
                    posic:=3;
                    x1:=x+3;
                end;
            3,4:if length(inp)>3 then
                begin
                    posic:=5;
                    x1:=x+6;
                end;
        end;
        gotoxy(x1,y);
    end;

    procedure datainput(x,y:integer;var inp:string;var ct:boolean;var ret:integer);
    var x1,conta,posic:integer;
        c:word;
    begin
        x1:=x;
        posic:=1;
        gotoxy(x1,y);
        c:=100;
        while (c<>CR) do
        begin
            c:=getkey;
            if (c>28) and (c<256) and (chr(c) in onlynum) then
            begin
                if (x1=x+1) or (x1=x+4) then
                    inc(x1);
                if ct=true then
                begin
                    if length(inp)+1<=6 then
                    begin
                        insert(chr(c),inp,posic);
                        if posic+1<=6 then
                        begin
                            inc(posic);
                            inc(x1);
                        end;
                    end
                end
                else
                begin
                    if (posic=length(inp)+1) and (length(inp)<6) then
                        inp[0]:=chr(ord(inp[0])+1);
                    inp[posic]:=chr(c);
                    if posic<6 then
                    begin
                        inc(x1);
                        inc(posic);
                    end;
                end;
            end
            else
            begin
                case c of
                    BS:bsk(x,y,x1,posic,inp);
                    HOME:homekey(x,y,x1,posic);
                    ENDK:endkey(inp,x,y,x1,posic);
                    LEFT:leftkey(x,y,x1,posic);
                    RIGHT:rightkey(x,y,inp,x1,posic);
                    CTRLLEFT:ctrll(x,y,inp,x1,posic);
                    CTRLRIGHT:ctrlr(x,y,inp,x1,posic);
                    INS:inskey(ct);
                    DEL:delk(x,y,x1,posic,inp);
                    TAB:tabkey(x,y,ct,x1,posic,inp);
                    CTRLY:ctrl_y(x,y,x1,posic,inp);
                    CTRLT:ctrl_t(x,y,x1,posic,inp);
                    UP:begin
                            ret:=1;
                            exit;
                       end;
                    DOWN:begin
                            ret:=2;
                            exit;
                         end;
                    ESC:begin
                            ret:=0;
                            exit;
                        end;
                end;
            end;
            writestr(x,y,inp,x1);
        end;
    end;

    function vali_date(inp:string):boolean;
    var x1,x2,x3,code:integer;
    begin
        val(inp[1]+inp[2],x1,code);
        val(inp[3]+inp[4],x2,code);
        val(inp[5]+inp[6],x3,code);
        if (inp<>'') then
        begin
            if (x2>0) and (x2<13) then
            begin
                case x2 of
                     1,3,5,7,8,10,12:if (x1>0) and (x1<32) then
                                         vali_date:=true
                                     else
                                         vali_date:=false;
                     4,6,9,11       :if (x1>0) and (x1<31) then
                                         vali_date:=true
                                     else
                                         vali_date:=false;
                     2              :if (x1>0) and (x1<30) then
                                     begin
                                         if (x3+1900) mod 4 <> 0 then
                                         begin
                                             if x1<29 then
                                                 vali_date:=true
                                             else
                                                 vali_date:=false;
                                         end
                                         else
                                             if x1<30 then
                                                 vali_date:=true
                                             else
                                                 vali_date:=false;
                                     end
                                     else
                                         vali_date:=false;
                 end;
            end
            else
                 vali_date:=false;
        end
        else
            vali_date:=true;
    end;

    procedure data(x,y:integer;ct:boolean;var inp:string; var ret:integer);
    var test:boolean;
    begin
        gotoxy(x,y);
        test:=false;
        while test=false do
        begin
              datainput(x,y,inp,ct,ret);
              test:=vali_date(inp);
        end;
    end;

    begin
    end.

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