CRT для консольного приложения

Code:

$IfDef VER130}

{$Define NEW_STYLES}

{$EndIf}

{$IfDef VER140}

{$Define NEW_STYLES}

{$EndIf}

{..$Define HARD_CRT}      {Redirect STD_...}

{..$Define CRT_EVENT}     {CTRL-C,...}

{$Define MOUSE_IS_USED}   {Handle mouse or not}

{..$Define OneByOne}      {Block or byte style write}

unit CRT32;

Interface

{$IfDef Win32}

Const

   { CRT modes of original CRT unit }

   BW40 = 0;     { 40x25 B/W on Color Adapter }

   CO40 = 1;     { 40x25 Color on Color Adapter }

   BW80 = 2;     { 80x25 B/W on Color Adapter }

   CO80 = 3;     { 80x25 Color on Color Adapter }

   Mono = 7;     { 80x25 on Monochrome Adapter }

   Font8x8 = 256;{ Add-in for ROM font }

   { Mode constants for 3.0 compatibility of original CRT unit }

   C40 = CO40;

   C80 = CO80;

   { Foreground and background color constants of original CRT unit }

   Black = 0;

   Blue = 1;

   Green = 2;

   Cyan = 3;

   Red = 4;

   Magenta = 5;

   Brown  6;

   LightGray = 7;

   { Foreground color constants of original CRT unit }

   DarkGray = 8;

   LightBlue = 9;

   LightGreen = 10;

   LightCyan = 11;

   LightRed = 12;

   LightMagenta = 13;

   Yellow = 14;

   White = 15;

   { Add-in for blinking of original CRT unit }

   Blink = 128;

   {  }

   {  New constans there are not in original CRT unit }

   {  }

   MouseLeftButton = 1;

   MouseRightButton = 2;

   MouseCenterButton = 4;

var

{ Interface variables of original CRT unit }

CheckBreak: Boolean;    { Enable Ctrl-Break }

CheckEOF: Boolean;      { Enable Ctrl-Z }

DirectVideo: Boolean;   { Enable direct video addressing }

CheckSnow: Boolean;     { Enable snow filtering }

LastMode: Word;         { Current text mode }

TextAttr: Byte;         { Current text attribute }

WindMin: Word;          { Window upper left coordinates }

WindMax: Word;          { Window lower right coordinates }

{  }

{  New variables there are not in original CRT unit }

{  }

MouseInstalled: boolean;

MousePressedButtons: word;

{ Interface functions & procedures of original CRT unit }

procedure AssignCrt(var F: Text);

function KeyPressed: Boolean;

function ReadKey: char;

procedure TextMode(Mode: Integer);

procedure Window(X1, Y1, X2, Y2: Byte);

procedure GotoXY(X, Y: Byte);

function WhereX: Byte;

function WhereY: Byte;

procedure ClrScr;

procedure ClrEol;

procedure InsLine;

procedure DelLine;

procedure TextColor(Color: Byte);

procedure TextBackground(Color: Byte);

procedure LowVideo;

procedure HighVideo;

procedure NormVideo;

procedure Delay(MS: Word);

procedure Sound(Hz: Word);

procedure NoSound;

{ New functions & procedures there are not in original CRT unit }

procedure FillerScreen(FillChar: Char);

procedure FlushInputBuffer;

function GetCursor: Word;

procedure SetCursor(NewCursor: Word);

function MouseKeyPressed: Boolean;

procedure MouseGotoXY(X, Y: Integer);

function MouseWhereY: Integer;

function MouseWhereX: Integer;

procedure MouseShowCursor;

procedure MouseHideCursor;

{ These functions & procedures are for inside use only }

function MouseReset: Boolean;

procedure WriteChrXY(X, Y: Byte; Chr: char);

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

{$EndIf Win32}

implementation

{$IfDef Win32}

uses Windows, SysUtils;

type

POpenText = ^TOpenText;

TOpenText = function(var F: Text; Mode: Word): Integer; far;

var

IsWinNT: boolean;

PtrOpenText: POpenText;

hConsoleInput: THandle;

hConsoleOutput: THandle;

ConsoleScreenRect: TSmallRect;

StartAttr: word;

LastX, LastY: byte;

SoundDuration: integer;

SoundFrequency: integer;

OldCP: integer;

MouseRowWidth, MouseColWidth: word;

MousePosX, MousePosY: smallInt;

MouseButtonPressed: boolean;

MouseEventTime: TDateTime;

{  }

{  This function handles the Write and WriteLn commands }

{  }

function TextOut(var F: Text): Integer; far;

{$IfDef OneByOne}

var

dwSize: DWORD;

{$EndIf}

begin

with TTExtRec(F) do

begin

   if BufPos > 0 then

   begin

     LastX := WhereX;

     LastY := WhereY;

     {$IfDef OneByOne}

     dwSize := 0;

     while (dwSize < BufPos) do

     begin

       WriteChrXY(LastX, LastY, BufPtr[dwSize]);

       Inc(dwSize);

     end;

     {$Else}

     WriteStrXY(LastX, LastY, BufPtr, BufPos);

     FillChar(BufPtr^, BufPos + 1, #0);

     {$EndIf}

     BufPos := 0;

   end;

end;

Result := 0;

end;

{  }

{  This function handles the exchanging of Input or Output }

{  }

function OpenText(var F: Text; Mode: Word): Integer; far;

var

OpenResult: integer;

begin

OpenResult := 102; { Text not assigned }

if Assigned(PtrOpenText) then

begin

   TTextRec(F).OpenFunc := PtrOpenText;

   OpenResult := PtrOpenText^(F, Mode);

   if OpenResult = 0 then

   begin

     if Mode = fmInput then

       hConsoleInput := TTextRec(F).Handle

     else

     begin

       hConsoleOutput := TTextRec(F).Handle;

       TTextRec(Output).InOutFunc := @TextOut;

       TTextRec(Output).FlushFunc := @TextOut;

     end;

   end;

end;

Result := OpenResult;

end;

{  }

{  Fills the current window with special character }

{  }

procedure FillerScreen(FillChar: Char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

Y: integer;

begin

Coord.X := ConsoleScreenRect.Left;

dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do

begin

   Coord.Y := Y;

   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

   FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);

end;

GotoXY(1,1);

end;

{  }

{  Write one character at the X,Y position }

{  }

procedure WriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

case Chr of

   #13: LastX := 1;

   #10:

     begin

       LastX := 1;

       Inc(LastY);

     end;

   else

     begin

       Coord.X := LastX - 1 + ConsoleScreenRect.Left;

       Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

       dwSize := 1;

       FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

       FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

       Inc(LastX);

     end;

end;

if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then

begin

   LastX := 1;

   Inc(LastY);

end;

if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

begin

   Dec(LastY);

   GotoXY(1,1);

   DelLine;

end;

GotoXY(LastX, LastY);

end;

{  }

{  Write string into the X,Y position }

{  }

(* !!! The WriteConsoleOutput does not write into the last line !!!

Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );

{$IfDef OneByOne}

   Var

     dwCount: integer;

{$Else}

   Type

     PBuffer= ^TBuffer;

     TBUffer= packed array [0..16384] of TCharInfo;

   Var

     I: integer;

     dwCount: DWORD;

     WidthHeight,Coord: TCoord;

     hTempConsoleOutput: THandle;

     SecurityAttributes: TSecurityAttributes;

     Buffer: PBuffer;

     DestinationScreenRect,SourceScreenRect: TSmallRect;

{$EndIf}

Begin

   If dwSize>0 Then Begin

     {$IfDef OneByOne}

       LastX:=X;

       LastY:=Y;

       dwCount:=0;

       While dwCount < dwSize Do Begin

         WriteChrXY(LastX,LastY,Str[dwCount]);

         Inc(dwCount);

       End;

     {$Else}

       SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);

       SecurityAttributes.lpSecurityDescriptor:=NIL;

       SecurityAttributes.bInheritHandle:=TRUE;

       hTempConsoleOutput:=CreateConsoleScreenBuffer(

        GENERIC_READ OR GENERIC_WRITE,

        FILE_SHARE_READ OR FILE_SHARE_WRITE,

        @SecurityAttributes,

        CONSOLE_TEXTMODE_BUFFER,

        NIL

       );

       If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin

         WidthHeight.X:=dwSize;

         WidthHeight.Y:=1;

       End Else Begin

         WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;

         WidthHeight.Y:=dwSize DIV WidthHeight.X;

         If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);

       End;

       SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);

       DestinationScreenRect.Left:=0;

       DestinationScreenRect.Top:=0;

       DestinationScreenRect.Right:=WidthHeight.X-1;

       DestinationScreenRect.Bottom:=WidthHeight.Y-1;

       SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);

       Coord.X:=0;

       For I:=1 To WidthHeight.Y Do Begin

         Coord.Y:=I-0;

         FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);

         FillConsoleOutputCharacter(hTempConsoleOutput,' '     ,WidthHeight.X,Coord,dwCount);

       End;

       WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);

       {  }

       New(Buffer);

       Coord.X:= 0;

       Coord.Y:= 0;

       SourceScreenRect.Left:=0;

       SourceScreenRect.Top:=0;

       SourceScreenRect.Right:=WidthHeight.X-1;

       SourceScreenRect.Bottom:=WidthHeight.Y-1;

       ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);

       Coord.X:=X-1;

       Coord.Y:=Y-1;

       DestinationScreenRect:=ConsoleScreenRect;

       WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);

       GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);

       Dispose(Buffer);

       {  }

       CloseHandle(hTempConsoleOutput);

     {$EndIf}

   End;

End;

*)

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

{$IfDef OneByOne}

var

dwCount: integer;

{$Else}

var

I: integer;

LineSize, dwCharCount, dwCount, dwWait: DWORD;

WidthHeight: TCoord;

OneLine: packed array [0..131] of char;

Line, TempStr: PChar;

procedure NewLine;

begin

   LastX := 1;

   Inc(LastY);

   if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

   begin

     Dec(LastY);

     GotoXY(1,1);

     DelLine;

   end;

   GotoXY(LastX, LastY);

end;

{$EndIf}

begin

if dwSize > 0 then

begin

   {$IfDef OneByOne}

   LastX := X;

   LastY := Y;

   dwCount := 0;

   while dwCount < dwSize do

   begin

     WriteChrXY(LastX, LastY, Str[dwCount]);

     Inc(dwCount);

   end;

   {$Else}

   LastX := X;

   LastY := Y;

   GotoXY(LastX, LastY);

   dwWait  := dwSize;

   TempStr := Str;

   while (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do

   begin

     Dec(dwWait, 2);

     Inc(TempStr, 2);

     NewLine;

   end;

   while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do

   begin

     Dec(dwWait);

     Inc(TempStr);

     NewLine;

   end;

   if dwWait > 0 then

   begin

     if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then

     begin

       WidthHeight.X := dwSize + LastX - 1;

       WidthHeight.Y := 1;

     end

     else

     begin

       WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

       WidthHeight.Y := dwSize div WidthHeight.X;

       if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);

     end;

     for I := 1 to WidthHeight.Y do

     begin

       FillChar(OneLine, SizeOf(OneLine), #0);

       Line := @OneLine;

       LineSize := WidthHeight.X - LastX + 1;

       if LineSize > dwWait then LineSize := dwWait;

       Dec(dwWait, LineSize);

       StrLCopy(Line, TempStr, LineSize);

       Inc(TempStr, LineSize);

       dwCharCount := Pos(#13#10, StrPas(Line));

       if dwCharCount > 0 then

       begin

         OneLine[dwCharCount - 1] := #0;

         OneLine[dwCharCount]     := #0;

         WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

         Inc(Line, dwCharCount + 1);

         NewLine;

         LineSize := LineSize - (dwCharCount + 1);

       end

       else

       begin

         dwCharCount := Pos(#10, StrPas(Line));

         if dwCharCount > 0 then

         begin

           OneLine[dwCharCount - 1] := #0;

           WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

           Inc(Line, dwCharCount);

           NewLine;

           LineSize := LineSize - dwCharCount;

         end;

       end;

       if LineSize <> 0 then

       begin

         WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);

       end;

       if dwWait > 0 then

       begin

         NewLine;

       end;

     end;

   end;

   {$EndIf}

end;

end;

{  }

{  Empty the buffer }

{  }

procedure FlushInputBuffer;

begin

FlushConsoleInputBuffer(hConsoleInput);

end;

{  }

{  Get size of current cursor }

{  }

function GetCursor: Word;

var

CCI: TConsoleCursorInfo;

begin

GetConsoleCursorInfo(hConsoleOutput, CCI);

GetCursor := CCI.dwSize;

end;

{  }

{  Set size of current cursor }

{  }

procedure SetCursor(NewCursor: Word);

var

CCI: TConsoleCursorInfo;

begin

if NewCursor = $0000 then

begin

   CCI.dwSize := GetCursor;

   CCI.bVisible := False;

end

else

begin

   CCI.dwSize := NewCursor;

   CCI.bVisible := True;

end;

SetConsoleCursorInfo(hConsoleOutput, CCI);

end;

{  }

{ --- Begin of Interface functions & procedures of original CRT unit --- }

procedure AssignCrt(var F: Text);

begin

Assign(F, '');

TTextRec(F).OpenFunc := @OpenText;

end;

function KeyPressed: Boolean;

var

NumberOfEvents: DWORD;

NumRead: DWORD;

InputRec: TInputRecord;

Pressed: boolean;

begin

Pressed := False;

GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);

if NumberOfEvents > 0 then

begin

   if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then

   begin

     if (InputRec.EventType = KEY_EVENT) and

       (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then

     begin

       Pressed := True;

       {$IfDef MOUSE_IS_USED}

       MouseButtonPressed := False;

       {$EndIf}

     end

     else

     begin

       {$IfDef MOUSE_IS_USED}

       if (InputRec.EventType = _MOUSE_EVENT) then

       begin

         with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do

         begin

           MousePosX := dwMousePosition.X;

           MousePosY := dwMousePosition.Y;

           if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then

           begin

             MouseEventTime := Now;

             MouseButtonPressed := True;

             {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}

             {End;}

           end;

         end;

       end;

       ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

       {$Else}

       ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

       {$EndIf}

     end;

   end;

end;

Result := Pressed;

end;

function ReadKey: char;

var

NumRead: DWORD;

InputRec: TInputRecord;

begin

repeat

   repeat

   until KeyPressed;

   ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;

Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;

end;

procedure TextMode(Mode: Integer);

begin

end;

procedure Window(X1, Y1, X2, Y2: Byte);

begin

ConsoleScreenRect.Left := X1 - 1;

ConsoleScreenRect.Top := Y1 - 1;

ConsoleScreenRect.Right := X2 - 1;

ConsoleScreenRect.Bottom := Y2 - 1;

WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;

WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;

{$IfDef WindowFrameToo}

SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);

{$EndIf}

GotoXY(1,1);

end;

procedure GotoXY(X, Y: Byte);

var

Coord: TCoord;

begin

Coord.X := X - 1 + ConsoleScreenRect.Left;

Coord.Y := Y - 1 + ConsoleScreenRect.Top;

if not SetConsoleCursorPosition(hConsoleOutput, Coord) then

begin

   GotoXY(1, 1);

   DelLine;

end;

end;

function WhereX: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;

end;

function WhereY: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;

end;

procedure ClrScr;

begin

FillerScreen(' ');

end;

procedure ClrEol;

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

Coord.X := WhereX - 1 + ConsoleScreenRect.Left;

Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;

dwSize  := ConsoleScreenRect.Right - Coord.X + 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);

end;

procedure InsLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharInfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;

SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top + 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

Dec(Coord.Y);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure DelLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharinfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top - 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure TextColor(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color and $0F) or (TextAttr and $F0);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure TextBackground(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color shl 4) or (TextAttr and $0F);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure LowVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr and $F7;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure HighVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr or $08;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure NormVideo;

begin

LastMode := TextAttr;

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure Delay(MS: Word);

{

Const

   Magic= $80000000;

var

  StartMS,CurMS,DeltaMS: DWORD;

  }

begin

Windows.SleepEx(MS, False);  // Windows.Sleep(MS);

   {

   StartMS:= GetTickCount;

   Repeat

     CurMS:= GetTickCount;

     If CurMS >= StartMS Then

        DeltaMS:= CurMS - StartMS

     Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);

   Until MS<DeltaMS;

   }

end;

procedure Sound(Hz: Word);

begin

{SetSoundIOPermissionMap(LocalIOPermission_ON);}

SoundFrequency := Hz;

if IsWinNT then

begin

   Windows.Beep(SoundFrequency, SoundDuration)

end

else

begin

   asm

       mov  BX,Hz

       cmp  BX,0

       jz   @2

       mov  AX,$34DD

       mov  DX,$0012

       cmp  DX,BX

       jnb  @2

       div BX

       mov  BX,AX

       { Sound is On ? }

       in   Al,$61

       test Al,$03

       jnz  @1

       { Set Sound On }

       or   Al,03

       out $61,Al

       { Timer Command }

       mov  Al,$B6

       out $43,Al

       { Set Frequency }

   @1: mov  Al,Bl

       out $42,Al

       mov  Al,Bh

       out $42,Al

   @2:

   end;

end;

end;

procedure NoSound;

begin

if IsWinNT then

begin

   Windows.Beep(SoundFrequency, 0);

end

else

begin

     asm

       { Set Sound On }

       in   Al,$61

       and Al,$FC

       out $61,Al

     end;

end;

{SetSoundIOPermissionMap(LocalIOPermission_OFF);}

end;

{ --- End of Interface functions & procedures of original CRT unit --- }

{  }

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

Coord.X := LastX - 1 + ConsoleScreenRect.Left;

Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

dwSize := 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

GotoXY(LastX, LastY);

end;

{  --------------------------------------------------  }

{  Console Event Handler }

{  }

{$IfDef CRT_EVENT}

function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;

var

S: {$IfDef Win32}ShortString{$Else}String{$EndIf};

Message: PChar;

begin

case CtrlType of

   CTRL_C_EVENT: S        := 'CTRL_C_EVENT';

   CTRL_BREAK_EVENT: S    := 'CTRL_BREAK_EVENT';

   CTRL_CLOSE_EVENT: S    := 'CTRL_CLOSE_EVENT';

   CTRL_LOGOFF_EVENT: S   := 'CTRL_LOGOFF_EVENT';

   CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';

   else

     S := 'UNKNOWN_EVENT';

end;

S := S + ' detected, but not handled.';

Message := @S;

Inc(Message);

MessageBox(0, Message, 'Win32 Console', MB_OK);

Result := True;

end;

{$EndIf}

function MouseReset: Boolean;

begin

MouseColWidth := 1;

MouseRowWidth := 1;

Result := True;

end;

procedure MouseShowCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then

begin

   cMode := cMode or ShowMouseConsoleMode;

   SetConsoleMode(hConsoleInput, cMode);

end;

end;

procedure MouseHideCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then

begin

   cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);

   SetConsoleMode(hConsoleInput, cMode);

end;

end;

function MouseKeyPressed: Boolean;

{$IfDef MOUSE_IS_USED}

const

MouseDeltaTime = 200;

var

ActualTime: TDateTime;

HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;

MSecTimeA, MSecTimeM: longInt;

MSecDelta: longInt;

{$EndIf}

begin

MousePressedButtons := 0;

{$IfDef MOUSE_IS_USED}

Result := False;

if MouseButtonPressed then

begin

   ActualTime := NOW;

   DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);

   DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);

   MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;

   MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;

   MSecDelta := Abs(MSecTimeM - MSecTimeA);

   if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then

   begin

     MousePressedButtons := MouseLeftButton;

     MouseButtonPressed := False;

     Result := True;

   end;

end;

{$Else}

Result := False;

{$EndIf}

end;

procedure MouseGotoXY(X, Y: Integer);

begin

{$IfDef MOUSE_IS_USED}

mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,

   X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());

MousePosY := (Y - 1) * MouseRowWidth;

MousePosX := (X - 1) * MouseColWidth;

{$EndIf}

end;

function MouseWhereY: Integer;

{$IfDef MOUSE_IS_USED}

   {Var

     lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

     {GetMouseMovePoints(

       SizeOf(TMouseMovePoint), lppt, lpptBuf,

       7,GMMP_USE_DRIVER_POINTS

     );

     Result:=lpptBuf.Y DIV MouseRowWidth;}

Result := (MousePosY div MouseRowWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

function MouseWhereX: Integer;

{$IfDef MOUSE_IS_USED}

   {Var

     lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

     {GetMouseMovePoints(

       SizeOf(TMouseMovePoint), lppt, lpptBuf,

       7,GMMP_USE_DRIVER_POINTS

     );

     Result:=lpptBuf.X DIV MouseColWidth;}

Result := (MousePosX div MouseColWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

{  }

procedure Init;

const

ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;

ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;

var

cMode: DWORD;

Coord: TCoord;

OSVersion: TOSVersionInfo;

CBI: TConsoleScreenBufferInfo;

begin

OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

GetVersionEx(OSVersion);

if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then

   IsWinNT := True

else

   IsWinNT := False;

PtrOpenText := TTextRec(Output).OpenFunc;

{$IfDef HARD_CRT}

AllocConsole;

Reset(Input);

hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);

TTextRec(Input).Handle := hConsoleInput;

ReWrite(Output);

hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);

TTextRec(Output).Handle := hConsoleOutput;

{$Else}

Reset(Input);

hConsoleInput := TTextRec(Input).Handle;

ReWrite(Output);

hConsoleOutput := TTextRec(Output).Handle;

{$EndIf}

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then

begin

   cMode := cMode or ExtInpConsoleMode;

   SetConsoleMode(hConsoleInput, cMode);

end;

TTextRec(Output).InOutFunc := @TextOut;

TTextRec(Output).FlushFunc := @TextOut;

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

GetConsoleMode(hConsoleOutput, cMode);

if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then

begin

   cMode := cMode or ExtOutConsoleMode;

   SetConsoleMode(hConsoleOutput, cMode);

end;

TextAttr  := CBI.wAttributes;

StartAttr := CBI.wAttributes;

LastMode  := CBI.wAttributes;

Coord.X := CBI.srWindow.Left;

Coord.Y := CBI.srWindow.Top;

WindMin := (Coord.Y shl 8) or Coord.X;

Coord.X := CBI.srWindow.Right;

Coord.Y := CBI.srWindow.Bottom;

WindMax := (Coord.Y shl 8) or Coord.X;

ConsoleScreenRect := CBI.srWindow;

SoundDuration := -1;

OldCp := GetConsoleOutputCP;

SetConsoleOutputCP(1250);

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, True);

{$EndIf}

{$IfDef MOUSE_IS_USED}

SetCapture(hConsoleInput);

KeyPressed;

{$EndIf}

MouseInstalled := MouseReset;

Window(1,1,80,25);

ClrScr;

end;

{  }

procedure Done;

begin

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, False);

{$EndIf}

SetConsoleOutputCP(OldCP);

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

ClrScr;

FlushInputBuffer;

{$IfDef HARD_CRT}

TTextRec(Input).Mode := fmClosed;

TTextRec(Output).Mode := fmClosed;

FreeConsole;

{$Else}

Close(Input);

Close(Output);

{$EndIf}

end;

initialization

Init;

finalization

Done;

{$Endif win32}

end.