Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
$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.

Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php