Umiestnenie súboru www.TrSek.com/cover/mojzis/crt_efd.pas//*** CRT_EFD v1.20 - (c)1998-2000, EFD Systems ***
//
//Win32 console mode unit designed to reproduce the text mode
//functionality found in the Crt unit of Turbo Pascal v7.0. See TP
//for docs. Several new procedures have been added for convenience.
//
//Known, minor incompatabilities
// - Direct manipulation of 'TextAttr' variable not supported, use SetTextattr().
// - Only text mode 'CO80' is supported. Mode constant 'Font8x8' sets 50 lines.
// - Window() is not supported.
//
//v1.1 - Modified ReadKey to return proper control and extended key codes
//v1.2 - Modified for D5 compatability
//
//LICENSE AGREEMENT and DISCLAIMER
//
//Copyrighted "freeware" for non-commercial use only. EFD Systems customers,
//clients and software licensees have full, unrestricted use of this unit.
//
//THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
//ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO
//THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
//PARTICULAR PURPOSE.
//
unit Crt_EFD;
interface
uses Windows, SysUtils;
const
Font8x8 = 256;
C080 = 3;
var
LastMode,TextAttr:Word;
//procedures corresponding to Turbo Pascal Crt unit
procedure ClrEol;
procedure ClrScr;
procedure InsLine;
procedure DelLine;
function WhereX : Integer;
function WhereY : Integer;
procedure GotoXY(X,Y : Integer);
procedure TextColor(Color:Word);
procedure TextBackGround(Color:Word);
procedure HighVideo;
procedure LowVideo;
procedure NormVideo;
function KeyPressed : Boolean;
function ReadKey : Char;
procedure Delay(Ms: DWord);
procedure Sound(Hz:DWord);
procedure NoSound;
procedure TextMode(Mode:Word);
//additional procedures
procedure FlushInputBuffer;
procedure SetTextAttr(Color:Word);
function GetTextAttr:Word;
procedure SetCursor(Size:Integer; Visible:Bool);
procedure WriteXY(Text:AnsiString; X,Y:Integer; Color:Word);
procedure SetFullScreen;
function GetConsoleWindow:THandle;
{Useful and relevant API routines
SetConsoleTitle()
}
implementation
const
FKeys = [#59..#68];
SKeys = [vk_shift,vk_control,vk_menu,vk_capital];
Ctrl_Pressed = Left_Ctrl_Pressed OR Right_Ctrl_Pressed;
Alt_Pressed = Left_Alt_Pressed OR Right_Alt_Pressed;
var
procedure ClrEol;
var
L, N : DWord;
begin
GetConsoleScreenBufferInfo(hStdOut, BI);
with BI do begin
L := dwSize.x-dwCursorPosition.x;
FillConsoleOutputAttribute(hStdOut, TextAttr, L, dwCursorPosition, N);
FillConsoleOutputCharacter(hStdOut, ' ', L, dwCursorPosition, N);
end;
end;
procedure ClrScr;
var
L,N : DWord;
begin
GetConsoleScreenBufferInfo(hStdOut, BI);
with BI do begin
dwCursorPosition.x:=0;
dwCursorPosition.y:=0;
L:=dwSize.x*dwSize.y;
FillConsoleOutputAttribute(hStdOut, TextAttr, L, dwCursorPosition, N);
FillConsoleOutputCharacter(hStdOut, ' ', L, dwCursorPosition, N);
SetConsoleCursorPosition(hStdout, dwCursorPosition);
end;
end;
function KeyPressed : Boolean;
var
I : DWord;
begin
GetNumberofConsoleInputEvents(hStdIn,I);
Result:=I>0;
end;
function ReadKey : Char;
var
I : DWord;
OK : Boolean;
begin
if LastKey=#0 then
Result:=LastScan
else begin
{$ifdef VER120}
with InRec.Event.KeyEvent do begin
{$else}{$ifdef VER130}
with InRec.Event.KeyEvent do begin
{$else}
with InRec.Event.KeyEvent do begin
{$endif}{$endif}
repeat
repeat
Ok:=ReadConsoleInput(hStdIn,InRec,1,I);
until OK and (InRec.EventType=KEY_EVENT) and (bKeyDown=False);
LastScan:=Char(wVirtualScanCode);
until not (wVirtualKeyCode in SKeys);
Result:=AsciiChar;
if dwControlKeyState<>0 then begin
if Result=#0 then begin
if (dwControlKeyState and Shift_Pressed)<>0 then begin
if LastScan in FKeys then LastScan:=Char(Ord(LastScan)+25);
end else if (dwControlKeyState and Ctrl_Pressed)<>0 then begin
if LastScan in FKeys then
LastScan:=Char(Ord(LastScan)+35)
else case LastScan of
#55:LastScan:=#114;
#73:LastScan:=#132;
#75:LastScan:=#115;
#77:LastScan:=#116;
#79:LastScan:=#117;
#81:LastScan:=#118;
end;
end else if (dwControlKeyState and Alt_Pressed)<>0 then begin
if LastScan in FKeys then LastScan:=Char(Ord(LastScan)+45);
end;
end else begin
if (dwControlKeyState and Ctrl_Pressed)<>0 then begin
if Result in ['a'..'z'] then Result:=Char(Ord(Result)-96)
end else if (dwControlKeyState and Alt_Pressed)<>0 then begin
I:=Pos(Result,AltKey);
if I>0 then begin
LastScan:=CvtKey[I];
Result:=#0;
end;
end else if (dwControlKeyState and Shift_Pressed)<>0 then begin
if Result=#9 then begin
Result:=#0;
LastScan:=#15;
end else CharUpper(PChar(Result));
end;
end;
end;
end;
end;
LastKey:=Result;
end;
function WhereX : Integer;
begin
GetConsoleScreenBufferInfo(hStdOut, BI);
Result := BI.dwCursorPosition.x+1;
end;
function WhereY : Integer;
begin
GetConsoleScreenBufferInfo(hStdOut, BI);
Result := BI.dwCursorPosition.y+1;
end;
procedure GotoXY(X,Y : Integer);
var
Coord : TCoord;
begin
Coord.x := X-1;
Coord.y := Y-1;
SetConsoleCursorPosition(hStdOut, Coord)
end;
procedure TextColor(Color : Word);
begin
TextAttr := (TextAttr AND $F0) OR Color;
SetConsoleTextAttribute(hStdOut,TextAttr);
end;
procedure TextBackGround(Color : Word);
begin
if Color<16 then Color := Color SHL 4;
TextAttr:=(TextAttr AND $F) OR Color;
SetConsoleTextAttribute(hStdOut,TextAttr);
end;
procedure HighVideo;
begin
TextAttr := TextAttr OR $8;
SetConsoleTextAttribute(hStdOut, TextAttr);
end;
procedure LowVideo;
begin
TextAttr := TextAttr AND $F7;
SetConsoleTextAttribute(hStdOut, TextAttr);
end;
procedure NormVideo;
begin
TextAttr := NormAttr;
SetConsoleTextAttribute(hStdOut, TextAttr);
end;
procedure ScrollV(YDelta : SmallInt);
var
CI : TCharInfo;
begin
GetConsoleScreenBufferInfo(hStdOut, BI);
with BI do begin
CI.AsciiChar := ' ';
CI.Attributes := TextAttr;
dwCursorPosition.x:=0;
if YDelta<0 then Inc(dwCursorPosition.y);
srWindow.Left:=dwCursorPosition.x;
srWindow.Top:=dwCursorPosition.y;
Inc(dwCursorPosition.y,YDelta);
ScrollConsoleScreenBuffer(hStdOut, srWindow, NIL, dwCursorPosition, CI);
end;
end;
procedure InsLine;
begin
ScrollV(1);
Dec(BI.dwCursorPosition.y);
SetConsoleCursorPosition(hStdOut, BI.dwCursorPosition);
end;
procedure DelLine;
begin
ScrollV(-1);
SetConsoleCursorPosition(hStdOut, BI.dwCursorPosition);
end;
procedure Delay(Ms: DWord);
begin
Sleep(Ms);
end;
procedure Sound(Hz : DWord);
begin
Windows.Beep(Hz, $FFFFFFFF);
end;
procedure NoSound;
begin
Windows.Beep(0, 0);
end;
procedure TextMode(Mode : Word);
var
Coord : TCoord;
begin
Coord.X := 80;
if (Mode AND Font8x8)<>0 then Coord.Y := 50 else Coord.Y := 25;
if SetConsoleScreenBufferSize(hStdOut,Coord) then begin
LastMode := CurMode;
CurMode := Mode;
end;
end;
procedure FlushInputBuffer;
//Clear all pending input
var
I:DWord;
begin
I:=0;
repeat
if FlushConsoleInputBuffer(hStdIn) then begin
Sleep(150);
GetNumberofConsoleInputEvents(hStdIn,I);
end else Break;
until I=0;
end;
procedure WriteXY(Text : AnsiString; X,Y : Integer; Color : Word);
//Write string in specified color at given location
var
Coord : TCoord;
N : DWord;
begin
Coord.x := X-1;
Coord.y := Y-1;
SetConsoleCursorPosition(hStdOut, Coord);
Write(Text);
FillConsoleOutputAttribute(hStdOut, Color, Length(Text), Coord, N);
end;
procedure SetCursor(Size : Integer; Visible : Bool);
//Set cursor size and visibility
var
CI : TConsoleCursorInfo;
begin
GetConsoleCursorInfo(hStdOut,CI);
if (Size>0) AND (Size<=100) then CI.dwSize := Size;
CI.bVisible := Visible;
SetConsoleCursorInfo(hStdOut,CI);
end;
procedure SetTextAttr(Color:Word);
//Set default text attributes
begin
TextAttr := Color;
SetConsoleTextAttribute(hStdOut, TextAttr);
end;
function GetTextAttr:Word;
begin
Result:=TextAttr;
end;
function GetConsoleWindow:THandle;
//Get handle for console Window
var
S:AnsiString;
C:Char;
begin
Result:=0;
Setlength(S,MAX_PATH+1);
if GetConsoleTitle(PChar(S),MAX_PATH)<>0 then begin
C:=S[1];
S[1]:='$';
SetConsoleTitle(PChar(S));
hConsole:=FindWindow(nil,PChar(S));
S[1]:=C;
SetConsoleTitle(PChar(S));
Result:=hConsole;
end;
end;