home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 03 / tricks / readkey.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-12-18  |  3.9 KB  |  122 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      READKEY.PAS                       *)
  3. (*          (c) 1990  Hagen Lehmann & TOOLBOX             *)
  4. (* ------------------------------------------------------ *)
  5. {$R-,S-,I-,D-,F-,V-,B-,N-,L-}
  6. {$M 1024,0,0}
  7.  
  8. USES
  9.   Crt, Dos;
  10. CONST
  11.   ErrorLevelFunc      = $4C;
  12.   DosInterrupt        = $21;
  13.   Attribute           : ARRAY [1..6] OF STRING [17]
  14.                           = ('HELL',
  15.                              'HELLUNTERSTRICHEN',
  16.                              'INVERS',
  17.                              'NORMAL',
  18.                              'SCHWARZ',
  19.                              'UNTERSTRICHEN');
  20.   AttrWerte           : ARRAY [1..6] OF BYTE
  21.                           = (15, 9, 120, 7, 0, 1);
  22. VAR
  23.   Taste               : CHAR;
  24.   Regs                : Registers;
  25.   Farbe, Text, Tasten : STRING;
  26.   Loop,Position       : BYTE;
  27.   AktivesAttr,
  28.   ErwFarbe            : WORD;
  29.   Fehler              : INTEGER;
  30.   FestFarbe           : BOOLEAN;
  31.  
  32.   FUNCTION UpString(Quelle : STRING) : STRING;
  33.   BEGIN
  34.     FOR Loop := 1 TO Length(Quelle) DO
  35.       Quelle[Loop] := UpCase(Quelle[Loop]);
  36.     UpString := Quelle;
  37.   END;
  38.  
  39.   PROCEDURE SetErrorLevel(FehlerCode : BYTE);
  40.   BEGIN
  41.     WITH Regs DO BEGIN
  42.       AH := ErrorLevelFunc;
  43.       AL := FehlerCode;
  44.       Intr(DosInterrupt, Regs);
  45.     END;
  46.   END;
  47.  
  48. BEGIN
  49.   AktivesAttr := TextAttr;
  50.   IF (ParamStr(1) = '?') OR (ParamCount = 0) THEN BEGIN
  51.     ClrScr;
  52.     WriteLn;
  53.     WriteLn('Aufruf : READKEY [["Text",Tasten [Farbe]]] ');
  54.     WriteLn;
  55.     WriteLn(' Mögliche Farben :');
  56.     WriteLn('  Hell, Hellunterstrichen, Invers, Normal, ',
  57.             'Schwarz,Unterstrichen');
  58.     WriteLn;
  59.     WriteLn(' Beispiel :');
  60.     WriteLn('   A:\>readkey "_Drücken_Sie_[J]a_oder_',
  61.             '[N]ein_",jn invers');
  62.     WriteLn('       (`_` steht für Leerzeichen)');
  63.     WriteLn('   A:\>readkey "_Laufwerk_[A]:_oder_[C]:_?_"',
  64.             ' ac 141');
  65.     WriteLn('       (141 ist ein erweitertes Attribut)');
  66.     Halt;
  67.   END;
  68.   Farbe     := UpString(ParamStr(2));
  69.   FestFarbe := FALSE;
  70.   IF Length(Farbe) > 0 THEN
  71.     FOR Loop := 1 TO 6 DO
  72.       IF Farbe = Attribute[Loop] THEN BEGIN
  73.         TextAttr  := AttrWerte[Loop];
  74.         Loop      := 6;
  75.         FestFarbe := TRUE;
  76.       END;
  77.   IF NOT FestFarbe THEN BEGIN
  78.     Val(Farbe, ErwFarbe, Fehler);
  79.     If Fehler = 0 THEN
  80.       TextAttr := ErwFarbe;
  81.   END;
  82.   Text     := ParamStr(1);
  83.   Tasten   := UpString(Text);
  84.   Position := Pos('",', Text);
  85.   IF (Text[1] = '"') AND ((Position > 1) OR
  86.      (Text[Length(Text)] = '"')) THEN BEGIN
  87.     Delete(Text, 1, 1);
  88.     IF Position > 1 THEN
  89.       Delete(Text, Position-1, Length(Text)-Position+2)
  90.     ELSE
  91.       Delete(Text, Length(Text), 1);
  92.    FOR Loop := 1 TO Length(Text) DO
  93.     IF Text[Loop] = '_' THEN
  94.       Text[Loop] := ' ';              { Leerzeichen setzen }
  95.     IF Position > 1 THEN
  96.       Delete(Tasten, 1, Position+1)
  97.                                     { Tasten herausfiltern }
  98.     ELSE
  99.       Tasten := '';
  100.     Write(Text);                          { Text schreiben }
  101.     IF Tasten <> '' THEN BEGIN
  102.                               { Abfrage mit Tastenvorgaben }
  103.       REPEAT
  104.         Taste := UpCase(ReadKey);         { Taste einlesen }
  105.       UNTIL Pos(Taste, Tasten) > 0;
  106.                       { Position der Taste in allen Tasten }
  107.       TextAttr := AktivesAttr; { Attribut wiederherstellen }
  108.       WriteLn;
  109.       SetErrorLevel(Pos(Taste, Tasten));
  110.                                    { Errorlevel = Position }
  111.     END ELSE BEGIN           { Abfrage ohne Tastenvorgaben }
  112.       Taste    := UpCase(ReadKey);
  113.       TextAttr := AktivesAttr;
  114.       WriteLn;
  115.       SetErrorLevel(Ord(Taste));
  116.                          { Errorlevel = Scancode der Taste }
  117.     END;
  118.   END;
  119. END.
  120. (* ------------------------------------------------------ *)
  121. (*               Ende von READKEY.PAS                     *)
  122.